Theory Complex_Matrix
section ‹Complex matrices›
theory Complex_Matrix
imports
"Jordan_Normal_Form.Matrix"
"Jordan_Normal_Form.Conjugate"
"Jordan_Normal_Form.Jordan_Normal_Form_Existence"
begin
subsection ‹Trace of a matrix›
definition trace :: "'a::ring mat ⇒ 'a" where
"trace A = (∑ i ∈ {0 ..< dim_row A}. A $$ (i,i))"
lemma trace_zero [simp]:
"trace (0⇩m n n) = 0"
by (simp add: trace_def)
lemma trace_id [simp]:
"trace (1⇩m n) = n"
by (simp add: trace_def)
lemma trace_comm:
fixes A B :: "'a::comm_ring mat"
assumes A: "A ∈ carrier_mat n n" and B: "B ∈ carrier_mat n n"
shows "trace (A * B) = trace (B * A)"
proof (simp add: trace_def)
have "(∑i = 0..<n. (A * B) $$ (i, i)) = (∑i = 0..<n. ∑j = 0..<n. A $$ (i,j) * B $$ (j,i))"
apply (rule sum.cong) using assms by (auto simp add: scalar_prod_def)
also have "… = (∑j = 0..<n. ∑i = 0..<n. A $$ (i,j) * B $$ (j,i))"
by (rule sum.swap)
also have "… = (∑j = 0..<n. col A j ∙ row B j)"
by (metis (no_types, lifting) A B atLeastLessThan_iff carrier_matD index_col index_row scalar_prod_def sum.cong)
also have "… = (∑j = 0..<n. row B j ∙ col A j)"
apply (rule sum.cong) apply auto
apply (subst comm_scalar_prod[where n=n]) apply auto
using assms by auto
also have "… = (∑j = 0..<n. (B * A) $$ (j, j))"
apply (rule sum.cong) using assms by auto
finally show "(∑i = 0..<dim_row A. (A * B) $$ (i, i)) = (∑i = 0..<dim_row B. (B * A) $$ (i, i))"
using A B by auto
qed
lemma trace_add_linear:
fixes A B :: "'a::comm_ring mat"
assumes A: "A ∈ carrier_mat n n" and B: "B ∈ carrier_mat n n"
shows "trace (A + B) = trace A + trace B" (is "?lhs = ?rhs")
proof -
have "?lhs = (∑i=0..<n. A$$(i, i) + B$$(i, i))" unfolding trace_def using A B by auto
also have "… = (∑i=0..<n. A$$(i, i)) + (∑i=0..<n. B$$(i, i))" by (auto simp add: sum.distrib)
finally have l: "?lhs = (∑i=0..<n. A$$(i, i)) + (∑i=0..<n. B$$(i, i))".
have r: "?rhs = (∑i=0..<n. A$$(i, i)) + (∑i=0..<n. B$$(i, i))" unfolding trace_def using A B by auto
from l r show ?thesis by auto
qed
lemma trace_minus_linear:
fixes A B :: "'a::comm_ring mat"
assumes A: "A ∈ carrier_mat n n" and B: "B ∈ carrier_mat n n"
shows "trace (A - B) = trace A - trace B" (is "?lhs = ?rhs")
proof -
have "?lhs = (∑i=0..<n. A$$(i, i) - B$$(i, i))" unfolding trace_def using A B by auto
also have "… = (∑i=0..<n. A$$(i, i)) - (∑i=0..<n. B$$(i, i))" by (auto simp add: sum_subtractf)
finally have l: "?lhs = (∑i=0..<n. A$$(i, i)) - (∑i=0..<n. B$$(i, i))".
have r: "?rhs = (∑i=0..<n. A$$(i, i)) - (∑i=0..<n. B$$(i, i))" unfolding trace_def using A B by auto
from l r show ?thesis by auto
qed
lemma trace_smult:
assumes "A ∈ carrier_mat n n"
shows "trace (c ⋅⇩m A) = c * trace A"
proof -
have "trace (c ⋅⇩m A) = (∑i = 0..<dim_row A. c * A $$ (i, i))" unfolding trace_def using assms by auto
also have "… = c * (∑i = 0..<dim_row A. A $$ (i, i))"
by (simp add: sum_distrib_left)
also have "… = c * trace A" unfolding trace_def by auto
ultimately show ?thesis by auto
qed
subsection ‹Conjugate of a vector›
lemma conjugate_scalar_prod:
fixes v w :: "'a::conjugatable_ring vec"
assumes "dim_vec v = dim_vec w"
shows "conjugate (v ∙ w) = conjugate v ∙ conjugate w"
using assms by (simp add: scalar_prod_def sum_conjugate conjugate_dist_mul)
subsection ‹Inner product›
abbreviation inner_prod :: "'a vec ⇒ 'a vec ⇒ 'a :: conjugatable_ring"
where "inner_prod v w ≡ w ∙c v"
lemma conjugate_scalar_prod_Im [simp]:
"Im (v ∙c v) = 0"
by (simp add: scalar_prod_def conjugate_vec_def sum.neutral)
lemma conjugate_scalar_prod_Re [simp]:
"Re (v ∙c v) ≥ 0"
by (simp add: scalar_prod_def conjugate_vec_def sum_nonneg)
lemma self_cscalar_prod_geq_0:
fixes v :: "'a::conjugatable_ordered_field vec"
shows "v ∙c v ≥ 0"
by (auto simp add: scalar_prod_def, rule sum_nonneg, rule conjugate_square_positive)
lemma inner_prod_distrib_left:
fixes u v w :: "('a::conjugatable_field) vec"
assumes dimu: "u ∈ carrier_vec n" and dimv:"v ∈ carrier_vec n" and dimw: "w ∈ carrier_vec n"
shows "inner_prod (v + w) u = inner_prod v u + inner_prod w u" (is "?lhs = ?rhs")
proof -
have dimcv: "conjugate v ∈ carrier_vec n" and dimcw: "conjugate w ∈ carrier_vec n" using assms by auto
have dimvw: "conjugate (v + w) ∈ carrier_vec n" using assms by auto
have "u ∙ (conjugate (v + w)) = u ∙ conjugate v + u ∙ conjugate w"
using dimv dimw dimu dimcv dimcw
by (metis conjugate_add_vec scalar_prod_add_distrib)
then show ?thesis by auto
qed
lemma inner_prod_distrib_right:
fixes u v w :: "('a::conjugatable_field) vec"
assumes dimu: "u ∈ carrier_vec n" and dimv:"v ∈ carrier_vec n" and dimw: "w ∈ carrier_vec n"
shows "inner_prod u (v + w) = inner_prod u v + inner_prod u w" (is "?lhs = ?rhs")
proof -
have dimvw: "v + w ∈ carrier_vec n" using assms by auto
have dimcu: "conjugate u ∈ carrier_vec n" using assms by auto
have "(v + w) ∙ (conjugate u) = v ∙ conjugate u + w ∙ conjugate u"
apply (simp add: comm_scalar_prod[OF dimvw dimcu])
apply (simp add: scalar_prod_add_distrib[OF dimcu dimv dimw])
apply (insert dimv dimw dimcu, simp add: comm_scalar_prod[of _ n])
done
then show ?thesis by auto
qed
lemma inner_prod_minus_distrib_right:
fixes u v w :: "('a::conjugatable_field) vec"
assumes dimu: "u ∈ carrier_vec n" and dimv:"v ∈ carrier_vec n" and dimw: "w ∈ carrier_vec n"
shows "inner_prod u (v - w) = inner_prod u v - inner_prod u w" (is "?lhs = ?rhs")
proof -
have dimvw: "v - w ∈ carrier_vec n" using assms by auto
have dimcu: "conjugate u ∈ carrier_vec n" using assms by auto
have "(v - w) ∙ (conjugate u) = v ∙ conjugate u - w ∙ conjugate u"
apply (simp add: comm_scalar_prod[OF dimvw dimcu])
apply (simp add: scalar_prod_minus_distrib[OF dimcu dimv dimw])
apply (insert dimv dimw dimcu, simp add: comm_scalar_prod[of _ n])
done
then show ?thesis by auto
qed
lemma inner_prod_smult_right:
fixes u v :: "complex vec"
assumes dimu: "u ∈ carrier_vec n" and dimv:"v ∈ carrier_vec n"
shows "inner_prod (a ⋅⇩v u) v = conjugate a * inner_prod u v" (is "?lhs = ?rhs")
using assms apply (simp add: scalar_prod_def conjugate_dist_mul)
apply (subst sum_distrib_left) by (rule sum.cong, auto)
lemma inner_prod_smult_left:
fixes u v :: "complex vec"
assumes dimu: "u ∈ carrier_vec n" and dimv: "v ∈ carrier_vec n"
shows "inner_prod u (a ⋅⇩v v) = a * inner_prod u v" (is "?lhs = ?rhs")
using assms apply (simp add: scalar_prod_def)
apply (subst sum_distrib_left) by (rule sum.cong, auto)
lemma inner_prod_smult_left_right:
fixes u v :: "complex vec"
assumes dimu: "u ∈ carrier_vec n" and dimv: "v ∈ carrier_vec n"
shows "inner_prod (a ⋅⇩v u) (b ⋅⇩v v) = conjugate a * b * inner_prod u v" (is "?lhs = ?rhs")
using assms apply (simp add: scalar_prod_def)
apply (subst sum_distrib_left) by (rule sum.cong, auto)
lemma inner_prod_swap:
fixes x y :: "complex vec"
assumes "y ∈ carrier_vec n" and "x ∈ carrier_vec n"
shows "inner_prod y x = conjugate (inner_prod x y)"
apply (simp add: scalar_prod_def)
apply (rule sum.cong) using assms by auto
text ‹Cauchy-Schwarz theorem for complex vectors. This is analogous to aux\_Cauchy
and Cauchy\_Schwarz\_ineq in Generalizations2.thy in QR\_Decomposition. Consider
merging and moving to Isabelle library.›
lemma aux_Cauchy:
fixes x y :: "complex vec"
assumes "x ∈ carrier_vec n" and "y ∈ carrier_vec n"
shows "0 ≤ inner_prod x x + a * (inner_prod x y) + (cnj a) * ((cnj (inner_prod x y)) + a * (inner_prod y y))"
proof -
have "(inner_prod (x+ a ⋅⇩v y) (x+a ⋅⇩v y)) = (inner_prod (x+a ⋅⇩v y) x) + (inner_prod (x+a ⋅⇩v y) (a ⋅⇩v y))"
apply (subst inner_prod_distrib_right) using assms by auto
also have "… = inner_prod x x + (a) * (inner_prod x y) + cnj a * ((cnj (inner_prod x y)) + (a) * (inner_prod y y))"
apply (subst (1 2) inner_prod_distrib_left[of _ n]) apply (auto simp add: assms)
apply (subst (1 2) inner_prod_smult_right[of _ n]) apply (auto simp add: assms)
apply (subst inner_prod_smult_left[of _ n]) apply (auto simp add: assms)
apply (subst inner_prod_swap[of y n x]) apply (auto simp add: assms)
unfolding distrib_left
by auto
finally show ?thesis by (metis self_cscalar_prod_geq_0)
qed
lemma Cauchy_Schwarz_complex_vec:
fixes x y :: "complex vec"
assumes "x ∈ carrier_vec n" and "y ∈ carrier_vec n"
shows "inner_prod x y * inner_prod y x ≤ inner_prod x x * inner_prod y y"
proof -
define cnj_a where "cnj_a = - (inner_prod x y)/ cnj (inner_prod y y)"
define a where "a = cnj (cnj_a)"
have cnj_rw: "(cnj a) = cnj_a"
unfolding a_def by (simp)
have rw_0: "cnj (inner_prod x y) + a * (inner_prod y y) = 0"
unfolding a_def cnj_a_def using assms(1) assms(2) conjugate_square_eq_0_vec by fastforce
have "0 ≤ (inner_prod x x + a * (inner_prod x y) + (cnj a) * ((cnj (inner_prod x y)) + a * (inner_prod y y)))"
using aux_Cauchy assms by auto
also have "… = (inner_prod x x + a * (inner_prod x y))" unfolding rw_0 by auto
also have "… = (inner_prod x x - (inner_prod x y) * cnj (inner_prod x y) / (inner_prod y y))"
unfolding a_def cnj_a_def by simp
finally have " 0 ≤ (inner_prod x x - (inner_prod x y) * cnj (inner_prod x y) / (inner_prod y y)) " .
hence "0 ≤ (inner_prod x x - (inner_prod x y) * cnj (inner_prod x y) / (inner_prod y y)) * (inner_prod y y)" by auto
also have "… = ((inner_prod x x)*(inner_prod y y) - (inner_prod x y) * cnj (inner_prod x y))"
by (smt add.inverse_neutral add_diff_cancel diff_0 diff_divide_eq_iff divide_cancel_right mult_eq_0_iff nonzero_mult_div_cancel_right rw_0)
finally have "(inner_prod x y) * cnj (inner_prod x y) ≤ (inner_prod x x)*(inner_prod y y)" by auto
then show ?thesis
apply (subst inner_prod_swap[of y n x]) by (auto simp add: assms)
qed
subsection ‹Hermitian adjoint of a matrix›
abbreviation adjoint where "adjoint ≡ mat_adjoint"
lemma adjoint_dim_row [simp]:
"dim_row (adjoint A) = dim_col A" by (simp add: mat_adjoint_def)
lemma adjoint_dim_col [simp]:
"dim_col (adjoint A) = dim_row A" by (simp add: mat_adjoint_def)
lemma adjoint_dim:
"A ∈ carrier_mat n n ⟹ adjoint A ∈ carrier_mat n n"
using adjoint_dim_col adjoint_dim_row by blast
lemma adjoint_def:
"adjoint A = mat (dim_col A) (dim_row A) (λ(i,j). conjugate (A $$ (j,i)))"
unfolding mat_adjoint_def mat_of_rows_def by auto
lemma adjoint_eval:
assumes "i < dim_col A" "j < dim_row A"
shows "(adjoint A) $$ (i,j) = conjugate (A $$ (j,i))"
using assms by (simp add: adjoint_def)
lemma adjoint_row:
assumes "i < dim_col A"
shows "row (adjoint A) i = conjugate (col A i)"
apply (rule eq_vecI)
using assms by (auto simp add: adjoint_eval)
lemma adjoint_col:
assumes "i < dim_row A"
shows "col (adjoint A) i = conjugate (row A i)"
apply (rule eq_vecI)
using assms by (auto simp add: adjoint_eval)
text ‹The identity <v, A w> = <A* v, w>›
lemma adjoint_def_alter:
fixes v w :: "'a::conjugatable_field vec"
and A :: "'a::conjugatable_field mat"
assumes dims: "v ∈ carrier_vec n" "w ∈ carrier_vec m" "A ∈ carrier_mat n m"
shows "inner_prod v (A *⇩v w) = inner_prod (adjoint A *⇩v v) w" (is "?lhs = ?rhs")
proof -
from dims have "?lhs = (∑i=0..<dim_vec v. (∑j=0..<dim_vec w.
conjugate (v$i) * A$$(i, j) * w$j))"
apply (simp add: scalar_prod_def sum_distrib_right )
apply (rule sum.cong, simp)
apply (rule sum.cong, auto)
done
moreover from assms have "?rhs = (∑i=0..<dim_vec v. (∑j=0..<dim_vec w.
conjugate (v$i) * A$$(i, j) * w$j))"
apply (simp add: scalar_prod_def adjoint_eval
sum_conjugate conjugate_dist_mul sum_distrib_left)
apply (subst sum.swap[where ?A = "{0..<n}"])
apply (rule sum.cong, simp)
apply (rule sum.cong, auto)
done
ultimately show ?thesis by simp
qed
lemma adjoint_one:
shows "adjoint (1⇩m n) = (1⇩m n::complex mat)"
apply (rule eq_matI)
by (auto simp add: adjoint_eval)
lemma adjoint_scale:
fixes A :: "'a::conjugatable_field mat"
shows "adjoint (a ⋅⇩m A) = (conjugate a) ⋅⇩m adjoint A"
apply (rule eq_matI) using conjugatable_ring_class.conjugate_dist_mul
by (auto simp add: adjoint_eval)
lemma adjoint_add:
fixes A B :: "'a::conjugatable_field mat"
assumes "A ∈ carrier_mat n m" "B ∈ carrier_mat n m"
shows "adjoint (A + B) = adjoint A + adjoint B"
apply (rule eq_matI)
using assms conjugatable_ring_class.conjugate_dist_add
by( auto simp add: adjoint_eval)
lemma adjoint_minus:
fixes A B :: "'a::conjugatable_field mat"
assumes "A ∈ carrier_mat n m" "B ∈ carrier_mat n m"
shows "adjoint (A - B) = adjoint A - adjoint B"
apply (rule eq_matI)
using assms apply(auto simp add: adjoint_eval)
by (metis add_uminus_conv_diff conjugate_dist_add conjugate_neg)
lemma adjoint_mult:
fixes A B :: "'a::conjugatable_field mat"
assumes "A ∈ carrier_mat n m" "B ∈ carrier_mat m l"
shows "adjoint (A * B) = adjoint B * adjoint A"
proof (rule eq_matI, auto simp add: adjoint_eval adjoint_row adjoint_col)
fix i j
assume "i < dim_col B" "j < dim_row A"
show "conjugate (row A j ∙ col B i) = conjugate (col B i) ∙ conjugate (row A j)"
using assms apply (simp add: conjugate_scalar_prod)
apply (subst comm_scalar_prod[where n="dim_row B"])
by (auto simp add: carrier_vecI)
qed
lemma adjoint_adjoint:
fixes A :: "'a::conjugatable_field mat"
shows "adjoint (adjoint A) = A"
by (rule eq_matI, auto simp add: adjoint_eval)
lemma trace_adjoint_positive:
fixes A :: "complex mat"
shows "trace (A * adjoint A) ≥ 0"
apply (auto simp add: trace_def adjoint_col)
apply (rule sum_nonneg) by auto
subsection ‹Algebraic manipulations on matrices›
lemma right_add_zero_mat[simp]:
"(A :: 'a :: monoid_add mat) ∈ carrier_mat nr nc ⟹ A + 0⇩m nr nc = A"
by (intro eq_matI, auto)
lemma add_carrier_mat':
"A ∈ carrier_mat nr nc ⟹ B ∈ carrier_mat nr nc ⟹ A + B ∈ carrier_mat nr nc"
by simp
lemma minus_carrier_mat':
"A ∈ carrier_mat nr nc ⟹ B ∈ carrier_mat nr nc ⟹ A - B ∈ carrier_mat nr nc"
by auto
lemma swap_plus_mat:
fixes A B C :: "'a::semiring_1 mat"
assumes "A ∈ carrier_mat n n" "B ∈ carrier_mat n n" "C ∈ carrier_mat n n"
shows "A + B + C = A + C + B"
by (metis assms assoc_add_mat comm_add_mat)
lemma uminus_mat:
fixes A :: "complex mat"
assumes "A ∈ carrier_mat n n"
shows "-A = (-1) ⋅⇩m A"
by auto
ML_file "mat_alg.ML"
method_setup mat_assoc = ‹mat_assoc_method›
"Normalization of expressions on matrices"
lemma mat_assoc_test:
fixes A B C D :: "complex mat"
assumes "A ∈ carrier_mat n n" "B ∈ carrier_mat n n" "C ∈ carrier_mat n n" "D ∈ carrier_mat n n"
shows
"(A * B) * (C * D) = A * B * C * D"
"adjoint (A * adjoint B) * C = B * (adjoint A * C)"
"A * 1⇩m n * 1⇩m n * B * 1⇩m n = A * B"
"(A - B) + (B - C) = A + (-B) + B + (-C)"
"A + (B - C) = A + B - C"
"A - (B + C + D) = A - B - C - D"
"(A + B) * (B + C) = A * B + B * B + A * C + B * C"
"A - B = A + (-1) ⋅⇩m B"
"A * (B - C) * D = A * B * D - A * C * D"
"trace (A * B * C) = trace (B * C * A)"
"trace (A * B * C * D) = trace (C * D * A * B)"
"trace (A + B * C) = trace A + trace (C * B)"
"A + B = B + A"
"A + B + C = C + B + A"
"A + B + (C + D) = A + C + (B + D)"
using assms by (mat_assoc n)+
subsection ‹Hermitian matrices›
text ‹A Hermitian matrix is a matrix that is equal to its Hermitian adjoint.›
definition hermitian :: "'a::conjugatable_field mat ⇒ bool" where
"hermitian A ⟷ (adjoint A = A)"
lemma hermitian_one:
shows "hermitian ((1⇩m n)::('a::conjugatable_field mat))"
unfolding hermitian_def
proof-
have "conjugate (1::'a) = 1"
apply (subst mult_1_right[symmetric, of "conjugate 1"])
apply (subst conjugate_id[symmetric, of "conjugate 1 * 1"])
apply (subst conjugate_dist_mul)
apply auto
done
then show "adjoint ((1⇩m n)::('a::conjugatable_field mat)) = (1⇩m n)"
by (auto simp add: adjoint_eval)
qed
subsection ‹Inverse matrices›
lemma inverts_mat_symm:
fixes A B :: "'a::field mat"
assumes dim: "A ∈ carrier_mat n n" "B ∈ carrier_mat n n"
and AB: "inverts_mat A B"
shows "inverts_mat B A"
proof -
have "A * B = 1⇩m n" using dim AB unfolding inverts_mat_def by auto
with dim have "B * A = 1⇩m n" by (rule mat_mult_left_right_inverse)
then show "inverts_mat B A" using dim inverts_mat_def by auto
qed
lemma inverts_mat_unique:
fixes A B C :: "'a::field mat"
assumes dim: "A ∈ carrier_mat n n" "B ∈ carrier_mat n n" "C ∈ carrier_mat n n"
and AB: "inverts_mat A B" and AC: "inverts_mat A C"
shows "B = C"
proof -
have AB1: "A * B = 1⇩m n" using AB dim unfolding inverts_mat_def by auto
have "A * C = 1⇩m n" using AC dim unfolding inverts_mat_def by auto
then have CA1: "C * A = 1⇩m n" using mat_mult_left_right_inverse[of A n C] dim by auto
then have "C = C * 1⇩m n" using dim by auto
also have "… = C * (A * B)" using AB1 by auto
also have "… = (C * A) * B" using dim by auto
also have "… = 1⇩m n * B" using CA1 by auto
also have "… = B" using dim by auto
finally show "B = C" ..
qed
subsection ‹Unitary matrices›
text ‹A unitary matrix is a matrix whose Hermitian adjoint is also its inverse.›
definition unitary :: "'a::conjugatable_field mat ⇒ bool" where
"unitary A ⟷ A ∈ carrier_mat (dim_row A) (dim_row A) ∧ inverts_mat A (adjoint A)"
lemma unitaryD2:
assumes "A ∈ carrier_mat n n"
shows "unitary A ⟹ inverts_mat (adjoint A) A"
using assms adjoint_dim inverts_mat_symm unitary_def by blast
lemma unitary_simps [simp]:
"A ∈ carrier_mat n n ⟹ unitary A ⟹ adjoint A * A = 1⇩m n"
"A ∈ carrier_mat n n ⟹ unitary A ⟹ A * adjoint A = 1⇩m n"
apply (metis adjoint_dim_row carrier_matD(2) inverts_mat_def unitaryD2)
by (simp add: inverts_mat_def unitary_def)
lemma unitary_adjoint [simp]:
assumes "A ∈ carrier_mat n n" "unitary A"
shows "unitary (adjoint A)"
unfolding unitary_def
using adjoint_dim[OF assms(1)] assms by (auto simp add: unitaryD2[OF assms] adjoint_adjoint)
lemma unitary_one:
shows "unitary ((1⇩m n)::('a::conjugatable_field mat))"
unfolding unitary_def
proof -
define I where I_def[simp]: "I ≡ ((1⇩m n)::('a::conjugatable_field mat))"
have dim: "I ∈ carrier_mat n n" by auto
have "hermitian I" using hermitian_one by auto
hence "adjoint I = I" using hermitian_def by auto
with dim show "I ∈ carrier_mat (dim_row I) (dim_row I) ∧ inverts_mat I (adjoint I)"
unfolding inverts_mat_def using dim by auto
qed
lemma unitary_zero:
fixes A :: "'a::conjugatable_field mat"
assumes "A ∈ carrier_mat 0 0"
shows "unitary A"
unfolding unitary_def inverts_mat_def Let_def using assms by auto
lemma unitary_elim:
assumes dims: "A ∈ carrier_mat n n" "B ∈ carrier_mat n n" "P ∈ carrier_mat n n"
and uP: "unitary P" and eq: "P * A * adjoint P = P * B * adjoint P"
shows "A = B"
proof -
have dimaP: "adjoint P ∈ carrier_mat n n" using dims by auto
have iv: "inverts_mat P (adjoint P)" using uP unitary_def by auto
then have "P * (adjoint P) = 1⇩m n" using inverts_mat_def dims by auto
then have aPP: "adjoint P * P = 1⇩m n" using mat_mult_left_right_inverse[OF dims(3) dimaP] by auto
have "adjoint P * (P * A * adjoint P) * P = (adjoint P * P) * A * (adjoint P * P)"
using dims dimaP by (mat_assoc n)
also have "… = 1⇩m n * A * 1⇩m n" using aPP by auto
also have "… = A" using dims by auto
finally have eqA: "A = adjoint P * (P * A * adjoint P) * P" ..
have "adjoint P * (P * B * adjoint P) * P = (adjoint P * P) * B * (adjoint P * P)"
using dims dimaP by (mat_assoc n)
also have "… = 1⇩m n * B * 1⇩m n" using aPP by auto
also have "… = B" using dims by auto
finally have eqB: "B = adjoint P * (P * B * adjoint P) * P" ..
then show ?thesis using eqA eqB eq by auto
qed
lemma unitary_is_corthogonal:
fixes U :: "'a::conjugatable_field mat"
assumes dim: "U ∈ carrier_mat n n"
and U: "unitary U"
shows "corthogonal_mat U"
unfolding corthogonal_mat_def Let_def
proof (rule conjI)
have dima: "adjoint U ∈ carrier_mat n n" using dim by auto
have aUU: "mat_adjoint U * U = (1⇩m n)"
apply (insert U[unfolded unitary_def] dim dima, drule conjunct2)
apply (drule inverts_mat_symm[of "U", OF dim dima], unfold inverts_mat_def, auto)
done
then show "diagonal_mat (mat_adjoint U * U)"
by (simp add: diagonal_mat_def)
show "∀i<dim_col U. (mat_adjoint U * U) $$ (i, i) ≠ 0" using dim by (simp add: aUU)
qed
lemma unitary_times_unitary:
fixes P Q :: "'a:: conjugatable_field mat"
assumes dim: "P ∈ carrier_mat n n" "Q ∈ carrier_mat n n"
and uP: "unitary P" and uQ: "unitary Q"
shows "unitary (P * Q)"
proof -
have dim_pq: "P * Q ∈ carrier_mat n n" using dim by auto
have "(P * Q) * adjoint (P * Q) = P * (Q * adjoint Q) * adjoint P" using dim by (mat_assoc n)
also have "… = P * (1⇩m n) * adjoint P" using uQ dim by auto
also have "… = P * adjoint P" using dim by (mat_assoc n)
also have "… = 1⇩m n" using uP dim by simp
finally have "(P * Q) * adjoint (P * Q) = 1⇩m n" by auto
hence "inverts_mat (P * Q) (adjoint (P * Q))"
using inverts_mat_def dim_pq by auto
thus "unitary (P*Q)" using unitary_def dim_pq by auto
qed
lemma unitary_operator_keep_trace:
fixes U A :: "complex mat"
assumes dU: "U ∈ carrier_mat n n" and dA: "A ∈ carrier_mat n n" and u: "unitary U"
shows "trace A = trace (adjoint U * A * U)"
proof -
have u': "U * adjoint U = 1⇩m n" using u unfolding unitary_def inverts_mat_def using dU by auto
have "trace (adjoint U * A * U) = trace (U * adjoint U * A)" using dU dA by (mat_assoc n)
also have "… = trace A" using u' dA by auto
finally show ?thesis by auto
qed
subsection ‹Normalization of vectors›
definition vec_norm :: "complex vec ⇒ complex" where
"vec_norm v ≡ csqrt (v ∙c v)"
lemma vec_norm_geq_0:
fixes v :: "complex vec"
shows "vec_norm v ≥ 0"
unfolding vec_norm_def by (insert self_cscalar_prod_geq_0[of v], simp)
lemma vec_norm_zero:
fixes v :: "complex vec"
assumes dim: "v ∈ carrier_vec n"
shows "vec_norm v = 0 ⟷ v = 0⇩v n"
unfolding vec_norm_def
by (subst conjugate_square_eq_0_vec[OF dim, symmetric], rule csqrt_eq_0)
lemma vec_norm_ge_0:
fixes v :: "complex vec"
assumes dim_v: "v ∈ carrier_vec n" and neq0: "v ≠ 0⇩v n"
shows "vec_norm v > 0"
proof -
have geq: "vec_norm v ≥ 0" using vec_norm_geq_0 by auto
have neq: "vec_norm v ≠ 0"
apply (insert dim_v neq0)
apply (drule vec_norm_zero, auto)
done
show ?thesis using neq geq by (rule dual_order.not_eq_order_implies_strict)
qed
definition vec_normalize :: "complex vec ⇒ complex vec" where
"vec_normalize v = (if (v = 0⇩v (dim_vec v)) then v else 1 / (vec_norm v) ⋅⇩v v)"
lemma normalized_vec_dim[simp]:
assumes "(v::complex vec) ∈ carrier_vec n"
shows "vec_normalize v ∈ carrier_vec n"
unfolding vec_normalize_def using assms by auto
lemma vec_eq_norm_smult_normalized:
shows "v = vec_norm v ⋅⇩v vec_normalize v"
proof (cases "v = 0⇩v (dim_vec v)")
define n where "n = dim_vec v"
then have dimv: "v ∈ carrier_vec n" by auto
then have dimnv: "vec_normalize v ∈ carrier_vec n" by auto
{
case True
then have v0: "v = 0⇩v n" using n_def by auto
then have n0: "vec_norm v = 0" using vec_norm_def by auto
have "vec_norm v ⋅⇩v vec_normalize v = 0⇩v n"
unfolding smult_vec_def by (auto simp add: n0 carrier_vecD[OF dimnv])
then show ?thesis using v0 by auto
next
case False
then have v: "v ≠ 0⇩v n" using n_def by auto
then have ge0: "vec_norm v > 0" using vec_norm_ge_0 dimv by auto
have "vec_normalize v = (1 / vec_norm v) ⋅⇩v v" using False vec_normalize_def by auto
then have "vec_norm v ⋅⇩v vec_normalize v = (vec_norm v * (1 / vec_norm v)) ⋅⇩v v"
using smult_smult_assoc by auto
also have "… = v" using ge0 by auto
finally have "v = vec_norm v ⋅⇩v vec_normalize v"..
then show "v = vec_norm v ⋅⇩v vec_normalize v" using v by auto
}
qed
lemma normalized_cscalar_prod:
fixes v w :: "complex vec"
assumes dim_v: "v ∈ carrier_vec n" and dim_w: "w ∈ carrier_vec n"
shows "v ∙c w = (vec_norm v * vec_norm w) * (vec_normalize v ∙c vec_normalize w)"
unfolding vec_normalize_def apply (split if_split, split if_split)
proof (intro conjI impI)
note dim0 = dim_v dim_w
have dim: "dim_vec v = n" "dim_vec w = n" using dim0 by auto
{
assume "w = 0⇩v n" "v = 0⇩v n"
then have lhs: "v ∙c w = 0" by auto
then moreover have rhs: "vec_norm v * vec_norm w * (v ∙c w) = 0" by auto
ultimately have "v ∙c w = vec_norm v * vec_norm w * (v ∙c w)" by auto
}
with dim show "w = 0⇩v (dim_vec w) ⟹ v = 0⇩v (dim_vec v) ⟹ v ∙c w = vec_norm v * vec_norm w * (v ∙c w)" by auto
{
assume asm: "w = 0⇩v n" "v ≠ 0⇩v n"
then have w0: "conjugate w = 0⇩v n" by auto
with dim0 have "(1 / vec_norm v ⋅⇩v v) ∙c w = 0" by auto
then moreover have rhs: "vec_norm v * vec_norm w * ((1 / vec_norm v ⋅⇩v v) ∙c w) = 0" by auto
moreover have "v ∙c w = 0" using w0 dim0 by auto
ultimately have "v ∙c w = vec_norm v * vec_norm w * ((1 / vec_norm v ⋅⇩v v) ∙c w)" by auto
}
with dim show "w = 0⇩v (dim_vec w) ⟹ v ≠ 0⇩v (dim_vec v) ⟹ v ∙c w = vec_norm v * vec_norm w * ((1 / vec_norm v ⋅⇩v v) ∙c w)" by auto
{
assume asm: "w ≠ 0⇩v n" "v = 0⇩v n"
with dim0 have "v ∙c (1 / vec_norm w ⋅⇩v w) = 0" by auto
then moreover have rhs: "vec_norm v * vec_norm w * (v ∙c (1 / vec_norm w ⋅⇩v w)) = 0" by auto
moreover have "v ∙c w = 0" using asm dim0 by auto
ultimately have "v ∙c w = vec_norm v * vec_norm w * (v ∙c (1 / vec_norm w ⋅⇩v w))" by auto
}
with dim show "w ≠ 0⇩v (dim_vec w) ⟹ v = 0⇩v (dim_vec v) ⟹ v ∙c w = vec_norm v * vec_norm w * (v ∙c (1 / vec_norm w ⋅⇩v w))" by auto
{
assume asmw: "w ≠ 0⇩v n" and asmv: "v ≠ 0⇩v n"
have "vec_norm w > 0" by (insert asmw dim0, rule vec_norm_ge_0, auto)
then have cw: "conjugate (1 / vec_norm w) = 1 / vec_norm w" by (simp add: complex_eq_iff complex_is_Real_iff)
from dim0 have
"((1 / vec_norm v ⋅⇩v v) ∙c (1 / vec_norm w ⋅⇩v w)) = 1 / vec_norm v * (v ∙c (1 / vec_norm w ⋅⇩v w))" by auto
also have "… = 1 / vec_norm v * (v ∙ (conjugate (1 / vec_norm w) ⋅⇩v conjugate w))"
by (subst conjugate_smult_vec, auto)
also have "… = 1 / vec_norm v * conjugate (1 / vec_norm w) * (v ∙ conjugate w)" using dim by auto
also have "… = 1 / vec_norm v * (1 / vec_norm w) * (v ∙c w)" using vec_norm_ge_0 cw by auto
finally have eq1: "(1 / vec_norm v ⋅⇩v v) ∙c (1 / vec_norm w ⋅⇩v w) = 1 / vec_norm v * (1 / vec_norm w) * (v ∙c w)" .
then have "vec_norm v * vec_norm w * ((1 / vec_norm v ⋅⇩v v) ∙c (1 / vec_norm w ⋅⇩v w)) = (v ∙c w)"
by (subst eq1, insert vec_norm_ge_0[of v n, OF dim_v asmv] vec_norm_ge_0[of w n, OF dim_w asmw], auto)
}
with dim show " w ≠ 0⇩v (dim_vec w) ⟹ v ≠ 0⇩v (dim_vec v) ⟹ v ∙c w = vec_norm v * vec_norm w * ((1 / vec_norm v ⋅⇩v v) ∙c (1 / vec_norm w ⋅⇩v w))" by auto
qed
lemma normalized_vec_norm :
fixes v :: "complex vec"
assumes dim_v: "v ∈ carrier_vec n"
and neq0: "v ≠ 0⇩v n"
shows "vec_normalize v ∙c vec_normalize v = 1"
unfolding vec_normalize_def
proof (simp, rule conjI)
show "v = 0⇩v (dim_vec v) ⟶ v ∙c v = 1" using neq0 dim_v by auto
have dim_a: "(vec_normalize v) ∈ carrier_vec n" "conjugate (vec_normalize v) ∈ carrier_vec n" using dim_v vec_normalize_def by auto
note dim = dim_v dim_a
have nvge0: "vec_norm v > 0" using vec_norm_ge_0 neq0 dim_v by auto
then have vvvv: "v ∙c v = (vec_norm v) * (vec_norm v)" unfolding vec_norm_def by (metis power2_csqrt power2_eq_square)
from nvge0 have "conjugate (vec_norm v) = vec_norm v" by (simp add: complex_eq_iff complex_is_Real_iff)
then have "v ∙c (1 / vec_norm v ⋅⇩v v) = 1 / vec_norm v * (v ∙c v)"
by (subst conjugate_smult_vec, auto)
also have "… = 1 / vec_norm v * vec_norm v * vec_norm v" using vvvv by auto
also have "… = vec_norm v" by auto
finally have "v ∙c (1 / vec_norm v ⋅⇩v v) = vec_norm v".
then show "v ≠ 0⇩v (dim_vec v) ⟶ vec_norm v ≠ 0 ∧ v ∙c (1 / vec_norm v ⋅⇩v v) = vec_norm v"
using neq0 nvge0 by auto
qed
lemma normalize_zero:
assumes "v ∈ carrier_vec n"
shows "vec_normalize v = 0⇩v n ⟷ v = 0⇩v n"
proof
show "v = 0⇩v n ⟹ vec_normalize v = 0⇩v n" unfolding vec_normalize_def by auto
next
have "v ≠ 0⇩v n ⟹ vec_normalize v ≠ 0⇩v n" unfolding vec_normalize_def
proof (simp, rule impI)
assume asm: "v ≠ 0⇩v n"
then have "vec_norm v > 0" using vec_norm_ge_0 assms by auto
then have nvge0: "1 / vec_norm v > 0" by (simp add: complex_is_Real_iff)
have "∃k < n. v $ k ≠ 0" using asm assms by auto
then obtain k where kn: "k < n" and vkneq0: "v $ k ≠ 0" by auto
then have "(1 / vec_norm v ⋅⇩v v) $ k = (1 / vec_norm v) * (v $ k)"
using assms carrier_vecD index_smult_vec(1) by blast
with nvge0 vkneq0 have "(1 / vec_norm v ⋅⇩v v) $ k ≠ 0" by auto
then show "1 / vec_norm v ⋅⇩v v ≠ 0⇩v n" using assms kn by fastforce
qed
then show "vec_normalize v = 0⇩v n ⟹ v = 0⇩v n" by auto
qed
lemma normalize_normalize[simp]:
"vec_normalize (vec_normalize v) = vec_normalize v"
proof (rule disjE[of "v = 0⇩v (dim_vec v)" "v ≠ 0⇩v (dim_vec v)"], auto)
let ?n = "dim_vec v"
{
assume "v = 0⇩v ?n"
then have "vec_normalize v = v" unfolding vec_normalize_def by auto
then show "vec_normalize (vec_normalize v) = vec_normalize v" by auto
}
assume neq0: "v ≠ 0⇩v ?n"
have dim: "v ∈ carrier_vec ?n" by auto
have "vec_norm (vec_normalize v) = 1" unfolding vec_norm_def
using normalized_vec_norm[OF dim neq0] by auto
then show "vec_normalize (vec_normalize v) = vec_normalize v"
by (subst (1) vec_normalize_def, simp)
qed
subsection ‹Spectral decomposition of normal complex matrices›
lemma normalize_keep_corthogonal:
fixes vs :: "complex vec list"
assumes cor: "corthogonal vs" and dims: "set vs ⊆ carrier_vec n"
shows "corthogonal (map vec_normalize vs)"
unfolding corthogonal_def
proof (rule allI, rule impI, rule allI, rule impI, goal_cases)
case c: (1 i j)
let ?m = "length vs"
have len: "length (map vec_normalize vs) = ?m" by auto
have dim: "⋀k. k < ?m ⟹ (vs ! k) ∈ carrier_vec n" using dims by auto
have map: "⋀k. k < ?m ⟹ map vec_normalize vs ! k = vec_normalize (vs ! k)" by auto
have eq1: "⋀j k. j < ?m ⟹ k < ?m ⟹ ((vs ! j) ∙c (vs ! k) = 0) = (j ≠ k)" using assms unfolding corthogonal_def by auto
then have "⋀k. k < ?m ⟹ (vs ! k) ∙c (vs ! k) ≠ 0 " by auto
then have "⋀k. k < ?m ⟹ (vs ! k) ≠ (0⇩v n)" using dim
by (auto simp add: conjugate_square_eq_0_vec[of _ n, OF dim])
then have vnneq0: "⋀k. k < ?m ⟹ vec_norm (vs ! k) ≠ 0" using vec_norm_zero[OF dim] by auto
then have i0: "vec_norm (vs ! i) ≠ 0" and j0: "vec_norm (vs ! j) ≠ 0" using c by auto
have "(vs ! i) ∙c (vs ! j) = vec_norm (vs ! i) * vec_norm (vs ! j) * (vec_normalize (vs ! i) ∙c vec_normalize (vs ! j))"
by (subst normalized_cscalar_prod[of "vs ! i" n "vs ! j"], auto, insert dim c, auto)
with i0 j0 have "(vec_normalize (vs ! i) ∙c vec_normalize (vs ! j) = 0) = ((vs ! i) ∙c (vs ! j) = 0)" by auto
with eq1 c have "(vec_normalize (vs ! i) ∙c vec_normalize (vs ! j) = 0) = (i ≠ j)" by auto
with map c show "(map vec_normalize vs ! i ∙c map vec_normalize vs ! j = 0) = (i ≠ j)" by auto
qed
lemma normalized_corthogonal_mat_is_unitary:
assumes W: "set ws ⊆ carrier_vec n"
and orth: "corthogonal ws"
and len: "length ws = n"
shows "unitary (mat_of_cols n (map vec_normalize ws))" (is "unitary ?W")
proof -
define vs where "vs = map vec_normalize ws"
define W where "W = mat_of_cols n vs"
have W': "set vs ⊆ carrier_vec n" using assms vs_def by auto
then have W'': "⋀k. k < length vs ⟹ vs ! k ∈ carrier_vec n" by auto
have orth': "corthogonal vs" using assms normalize_keep_corthogonal vs_def by auto
have len'[simp]: "length vs = n" using assms vs_def by auto
have dimW: "W ∈ carrier_mat n n" using W_def len by auto
have "adjoint W ∈ carrier_mat n n" using dimW by auto
then have dimaW: "mat_adjoint W ∈ carrier_mat n n" by auto
{
fix i j assume i: "i < n" and j: "j < n"
have dimws: "(ws ! i) ∈ carrier_vec n" "(ws ! j) ∈ carrier_vec n" using W len i j by auto
have "(ws ! i) ∙c (ws ! i) ≠ 0" "(ws ! j) ∙c (ws ! j) ≠ 0" using orth corthogonal_def[of ws] len i j by auto
then have neq0: "(ws ! i) ≠ 0⇩v n" "(ws ! j) ≠ 0⇩v n"
by (auto simp add: conjugate_square_eq_0_vec[of "ws ! i" n])
then have "vec_norm (ws ! i) > 0" "vec_norm (ws ! j) > 0" using vec_norm_ge_0 dimws by auto
then have ge0: "vec_norm (ws ! i) * vec_norm (ws ! j) > 0" by auto
have ws': "vs ! i = vec_normalize (ws ! i)"
"vs ! j = vec_normalize (ws ! j)"
using len i j vs_def by auto
have ii1: "(vs ! i) ∙c (vs ! i) = 1"
apply (simp add: ws')
apply (rule normalized_vec_norm[of "ws ! i"], rule dimws, rule neq0)
done
have ij0: "i ≠ j ⟹ (ws ! i) ∙c (ws ! j) = 0" using i j
by (insert orth, auto simp add: corthogonal_def[of ws] len)
have "i ≠ j ⟹ (ws ! i) ∙c (ws ! j) = (vec_norm (ws ! i) * vec_norm (ws ! j)) * ((vs ! i) ∙c (vs ! j))"
apply (auto simp add: ws')
apply (rule normalized_cscalar_prod)
apply (rule dimws, rule dimws)
done
with ij0 have ij0': "i ≠ j ⟹ (vs ! i) ∙c (vs ! j) = 0" using ge0 by auto
have cWk: "⋀k. k < n ⟹ col W k = vs ! k" unfolding W_def
apply (subst col_mat_of_cols)
apply (auto simp add: W'')
done
have "(mat_adjoint W * W) $$ (j, i) = row (mat_adjoint W) j ∙ col W i"
by (insert dimW i j dimaW, auto)
also have "… = conjugate (col W j) ∙ col W i"
by (insert dimW i j dimaW, auto simp add: mat_adjoint_def)
also have "… = col W i ∙ conjugate (col W j)" using comm_scalar_prod[of "col W i" n] dimW by auto
also have "… = (vs ! i) ∙c (vs ! j)" using W_def col_mat_of_cols i j len cWk by auto
finally have "(mat_adjoint W * W) $$ (j, i) = (vs ! i) ∙c (vs ! j)".
then have "(mat_adjoint W * W) $$ (j, i) = (if (j = i) then 1 else 0)"
by (auto simp add: ii1 ij0')
}
note maWW = this
then have "mat_adjoint W * W = 1⇩m n" unfolding one_mat_def using dimW dimaW
by (auto simp add: maWW adjoint_def)
then have iv0: "adjoint W * W = 1⇩m n" by auto
have dimaW: "adjoint W ∈ carrier_mat n n" using dimaW by auto
then have iv1: "W * adjoint W = 1⇩m n" using mat_mult_left_right_inverse dimW iv0 by auto
then show "unitary W" unfolding unitary_def inverts_mat_def using dimW dimaW iv0 iv1 by auto
qed
lemma normalize_keep_eigenvector:
assumes ev: "eigenvector A v e"
and dim: "A ∈ carrier_mat n n" "v ∈ carrier_vec n"
shows "eigenvector A (vec_normalize v) e"
unfolding eigenvector_def
proof
show "vec_normalize v ∈ carrier_vec (dim_row A)" using dim by auto
have eg: "A *⇩v v = e ⋅⇩v v" using ev dim eigenvector_def by auto
have vneq0: "v ≠ 0⇩v n" using ev dim unfolding eigenvector_def by auto
then have s0: "vec_normalize v ≠ 0⇩v n"
by (insert dim, subst normalize_zero[of v], auto)
from vneq0 have vvge0: "vec_norm v > 0" using vec_norm_ge_0 dim by auto
have s1: "A *⇩v vec_normalize v = e ⋅⇩v vec_normalize v" unfolding vec_normalize_def
using vneq0 dim
apply (auto, simp add: mult_mat_vec)
apply (subst eg, auto)
done
with s0 dim show "vec_normalize v ≠ 0⇩v (dim_row A) ∧ A *⇩v vec_normalize v = e ⋅⇩v vec_normalize v" by auto
qed
lemma four_block_mat_adjoint:
fixes A B C D :: "'a::conjugatable_field mat"
assumes dim: "A ∈ carrier_mat nr1 nc1" "B ∈ carrier_mat nr1 nc2"
"C ∈ carrier_mat nr2 nc1" "D ∈ carrier_mat nr2 nc2"
shows "adjoint (four_block_mat A B C D)
= four_block_mat (adjoint A) (adjoint C) (adjoint B) (adjoint D)"
by (rule eq_matI, insert dim, auto simp add: adjoint_eval)
fun unitary_schur_decomposition :: "complex mat ⇒ complex list ⇒ complex mat × complex mat × complex mat" where
"unitary_schur_decomposition A [] = (A, 1⇩m (dim_row A), 1⇩m (dim_row A))"
| "unitary_schur_decomposition A (e # es) = (let
n = dim_row A;
n1 = n - 1;
v' = find_eigenvector A e;
v = vec_normalize v';
ws0 = gram_schmidt n (basis_completion v);
ws = map vec_normalize ws0;
W = mat_of_cols n ws;
W' = corthogonal_inv W;
A' = W' * A * W;
(A1,A2,A0,A3) = split_block A' 1 1;
(B,P,Q) = unitary_schur_decomposition A3 es;
z_row = (0⇩m 1 n1);
z_col = (0⇩m n1 1);
one_1 = 1⇩m 1
in (four_block_mat A1 (A2 * P) A0 B,
W * four_block_mat one_1 z_row z_col P,
four_block_mat one_1 z_row z_col Q * W'))"
theorem unitary_schur_decomposition:
assumes A: "(A::complex mat) ∈ carrier_mat n n"
and c: "char_poly A = (∏ (e :: complex) ← es. [:- e, 1:])"
and B: "unitary_schur_decomposition A es = (B,P,Q)"
shows "similar_mat_wit A B P Q ∧ upper_triangular B ∧ diag_mat B = es ∧ unitary P ∧ (Q = adjoint P)"
using assms
proof (induct es arbitrary: n A B P Q)
case Nil
with degree_monic_char_poly[of A n]
show ?case by (auto intro: similar_mat_wit_refl simp: diag_mat_def unitary_zero)
next
case (Cons e es n A C P Q)
let ?n1 = "n - 1"
from Cons have A: "A ∈ carrier_mat n n" and dim: "dim_row A = n" by auto
let ?cp = "char_poly A"
from Cons(3)
have cp: "?cp = [: -e, 1 :] * (∏e ← es. [:- e, 1:])" by auto
have mon: "monic (∏e← es. [:- e, 1:])" by (rule monic_prod_list, auto)
have deg: "degree ?cp = Suc (degree (∏e← es. [:- e, 1:]))" unfolding cp
by (subst degree_mult_eq, insert mon, auto)
with degree_monic_char_poly[OF A] have n: "n ≠ 0" by auto
define v' where "v' = find_eigenvector A e"
define v where "v = vec_normalize v'"
define b where "b = basis_completion v"
define ws0 where "ws0 = gram_schmidt n b"
define ws where "ws = map vec_normalize ws0"
define W where "W = mat_of_cols n ws"
define W' where "W' = corthogonal_inv W"
define A' where "A' = W' * A * W"
obtain A1 A2 A0 A3 where splitA': "split_block A' 1 1 = (A1,A2,A0,A3)"
by (cases "split_block A' 1 1", auto)
obtain B P' Q' where schur: "unitary_schur_decomposition A3 es = (B,P',Q')"
by (cases "unitary_schur_decomposition A3 es", auto)
let ?P' = "four_block_mat (1⇩m 1) (0⇩m 1 ?n1) (0⇩m ?n1 1) P'"
let ?Q' = "four_block_mat (1⇩m 1) (0⇩m 1 ?n1) (0⇩m ?n1 1) Q'"
have C: "C = four_block_mat A1 (A2 * P') A0 B" and P: "P = W * ?P'" and Q: "Q = ?Q' * W'"
using Cons(4) unfolding unitary_schur_decomposition.simps
Let_def list.sel dim
v'_def[symmetric] v_def[symmetric] b_def[symmetric] ws0_def[symmetric] ws_def[symmetric] W'_def[symmetric] W_def[symmetric]
A'_def[symmetric] split splitA' schur by auto
have e: "eigenvalue A e"
unfolding eigenvalue_root_char_poly[OF A] cp by simp
from find_eigenvector[OF A e] have ev': "eigenvector A v' e" unfolding v'_def .
then have "v' ∈ carrier_vec n" unfolding eigenvector_def using A by auto
with ev' have ev: "eigenvector A v e" unfolding v_def using A dim normalize_keep_eigenvector by auto
from this[unfolded eigenvector_def]
have v[simp]: "v ∈ carrier_vec n" and v0: "v ≠ 0⇩v n" using A by auto
interpret cof_vec_space n "TYPE(complex)" .
from basis_completion[OF v v0, folded b_def]
have span_b: "span (set b) = carrier_vec n" and dist_b: "distinct b"
and indep: "¬ lin_dep (set b)" and b: "set b ⊆ carrier_vec n" and hdb: "hd b = v"
and len_b: "length b = n" by auto
from hdb len_b n obtain vs where bv: "b = v # vs" by (cases b, auto)
from gram_schmidt_result[OF b dist_b indep refl, folded ws0_def]
have ws0: "set ws0 ⊆ carrier_vec n" "corthogonal ws0" "length ws0 = n"
by (auto simp: len_b)
then have ws: "set ws ⊆ carrier_vec n" "corthogonal ws" "length ws = n" unfolding ws_def
using normalize_keep_corthogonal by auto
have ws0ne: "ws0 ≠ []" using ‹length ws0 = n› n by auto
from gram_schmidt_hd[OF v, of vs, folded bv] have hdws0: "hd ws0 = (vec_normalize v')" unfolding ws0_def v_def .
have "hd ws = vec_normalize (hd ws0)" unfolding ws_def using hd_map[OF ws0ne] by auto
then have hdws: "hd ws = v" unfolding v_def using normalize_normalize[of v'] hdws0 by auto
have orth_W: "corthogonal_mat W" using orthogonal_mat_of_cols ws unfolding W_def.
have W: "W ∈ carrier_mat n n"
using ws unfolding W_def using mat_of_cols_carrier(1)[of n ws] by auto
have W': "W' ∈ carrier_mat n n" unfolding W'_def corthogonal_inv_def using W
by (auto simp: mat_of_rows_def)
from corthogonal_inv_result[OF orth_W]
have W'W: "inverts_mat W' W" unfolding W'_def .
hence WW': "inverts_mat W W'" using mat_mult_left_right_inverse[OF W' W] W' W
unfolding inverts_mat_def by auto
have A': "A' ∈ carrier_mat n n" using W W' A unfolding A'_def by auto
have A'A_wit: "similar_mat_wit A' A W' W"
by (rule similar_mat_witI[of _ _ n], insert W W' A A' W'W WW', auto simp: A'_def
inverts_mat_def)
hence A'A: "similar_mat A' A" unfolding similar_mat_def by blast
from similar_mat_wit_sym[OF A'A_wit] have simAA': "similar_mat_wit A A' W W'" by auto
have eigen[simp]: "A *⇩v v = e ⋅⇩v v" and v0: "v ≠ 0⇩v n"
using v_def v'_def find_eigenvector[OF A e] A normalize_keep_eigenvector
unfolding eigenvector_def by auto
let ?f = "(λ i. if i = 0 then e else 0)"
have col0: "col A' 0 = vec n ?f"
unfolding A'_def W'_def W_def
using corthogonal_col_ev_0[OF A v v0 eigen n hdws ws].
from A' n have "dim_row A' = 1 + ?n1" "dim_col A' = 1 + ?n1" by auto
from split_block[OF splitA' this] have A2: "A2 ∈ carrier_mat 1 ?n1"
and A3: "A3 ∈ carrier_mat ?n1 ?n1"
and A'block: "A' = four_block_mat A1 A2 A0 A3" by auto
have A1id: "A1 = mat 1 1 (λ _. e)"
using splitA'[unfolded split_block_def Let_def] arg_cong[OF col0, of "λ v. v $ 0"] A' n
by (auto simp: col_def)
have A1: "A1 ∈ carrier_mat 1 1" unfolding A1id by auto
{
fix i
assume "i < ?n1"
with arg_cong[OF col0, of "λ v. v $ Suc i"] A'
have "A' $$ (Suc i, 0) = 0" by auto
} note A'0 = this
have A0id: "A0 = 0⇩m ?n1 1"
using splitA'[unfolded split_block_def Let_def] A'0 A' by auto
have A0: "A0 ∈ carrier_mat ?n1 1" unfolding A0id by auto
from cp char_poly_similar[OF A'A]
have cp: "char_poly A' = [: -e,1 :] * (∏ e ← es. [:- e, 1:])" by simp
also have "char_poly A' = char_poly A1 * char_poly A3"
unfolding A'block A0id
by (rule char_poly_four_block_zeros_col[OF A1 A2 A3])
also have "char_poly A1 = [: -e,1 :]"
by (simp add: A1id char_poly_defs det_def signof_def sign_def)
finally have cp: "char_poly A3 = (∏ e ← es. [:- e, 1:])"
by (metis mult_cancel_left pCons_eq_0_iff zero_neq_one)
from Cons(1)[OF A3 cp schur]
have simIH: "similar_mat_wit A3 B P' Q'" and ut: "upper_triangular B" and diag: "diag_mat B = es"
and uP': "unitary P'" and Q'P': "Q' = adjoint P'"
by auto
from similar_mat_witD2[OF A3 simIH]
have B: "B ∈ carrier_mat ?n1 ?n1" and P': "P' ∈ carrier_mat ?n1 ?n1" and Q': "Q' ∈ carrier_mat ?n1 ?n1"
and PQ': "P' * Q' = 1⇩m ?n1" by auto
have A0_eq: "A0 = P' * A0 * 1⇩m 1" unfolding A0id using P' by auto
have simA'C: "similar_mat_wit A' C ?P' ?Q'" unfolding A'block C
by (rule similar_mat_wit_four_block[OF similar_mat_wit_refl[OF A1] simIH _ A0_eq A1 A3 A0],
insert PQ' A2 P' Q', auto)
have ut1: "upper_triangular A1" unfolding A1id by auto
have ut: "upper_triangular C" unfolding C A0id
by (intro upper_triangular_four_block[OF _ B ut1 ut], auto simp: A1id)
from A1id have diagA1: "diag_mat A1 = [e]" unfolding diag_mat_def by auto
from diag_four_block_mat[OF A1 B] have diag: "diag_mat C = e # es" unfolding diag diagA1 C by simp
have aW: "adjoint W ∈ carrier_mat n n" using W by auto
have aW': "adjoint W' ∈ carrier_mat n n" using W' by auto
have "unitary W" using W_def ws_def ws0 normalized_corthogonal_mat_is_unitary by auto
then have ivWaW: "inverts_mat W (adjoint W)" using unitary_def W aW by auto
with WW' have W'aW: "W' = (adjoint W)" using inverts_mat_unique W W' aW by auto
then have "adjoint W' = W" using adjoint_adjoint by auto
with ivWaW have "inverts_mat W' (adjoint W')" using inverts_mat_symm W aW W'aW by auto
then have "unitary W'" using unitary_def W' by auto
have newP': "P' ∈ carrier_mat (n - Suc 0) (n - Suc 0)" using P' by auto
have rl: "⋀ x1 x2 x3 x4 y1 y2 y3 y4 f. x1 = y1 ⟹ x2 = y2 ⟹ x3 = y3 ⟹ x4 = y4 ⟹ f x1 x2 x3 x4 = f y1 y2 y3 y4" by simp
have Q'aP': "?Q' = adjoint ?P'"
apply (subst four_block_mat_adjoint, auto simp add: newP')
apply (rule rl[where f2 = four_block_mat])
apply (auto simp add: eq_matI adjoint_eval Q'P')
done
have "adjoint P = adjoint ?P' * adjoint W" using W newP' n
apply (simp add: P)
apply (subst adjoint_mult[of W, symmetric])
apply (auto simp add: W P' carrier_matD[of W n n])
done
also have "… = ?Q' * W'" using Q'aP' W'aW by auto
also have "… = Q" using Q by auto
finally have QaP: "Q = adjoint P" ..
from similar_mat_wit_trans[OF simAA' simA'C, folded P Q] have smw: "similar_mat_wit A C P Q" by blast
then have dimP: "P ∈ carrier_mat n n" and dimQ: "Q ∈ carrier_mat n n" unfolding similar_mat_wit_def using A by auto
from smw have "P * Q = 1⇩m n" unfolding similar_mat_wit_def using A by auto
then have "inverts_mat P Q" using inverts_mat_def dimP by auto
then have uP: "unitary P" using QaP unitary_def dimP by auto
from ut similar_mat_wit_trans[OF simAA' simA'C, folded P Q] diag uP QaP
show ?case by blast
qed
lemma complex_mat_char_poly_factorizable:
fixes A :: "complex mat"
assumes "A ∈ carrier_mat n n"
shows "∃as. char_poly A = (∏ a ← as. [:- a, 1:]) ∧ length as = n"
proof -
let ?ca = "char_poly A"
have ex0: "∃bs. Polynomial.smult (lead_coeff ?ca) (∏b←bs. [:- b, 1:]) = ?ca ∧
length bs = degree ?ca"
by (simp add: fundamental_theorem_algebra_factorized)
then obtain bs where " Polynomial.smult (lead_coeff ?ca) (∏b←bs. [:- b, 1:]) = ?ca ∧
length bs = degree ?ca" by auto
moreover have "lead_coeff ?ca = (1::complex)"
using assms degree_monic_char_poly by blast
ultimately have ex1: "?ca = (∏b←bs. [:- b, 1:]) ∧ length bs = degree ?ca" by auto
moreover have "degree ?ca = n"
by (simp add: assms degree_monic_char_poly)
ultimately show ?thesis by auto
qed
lemma complex_mat_has_unitary_schur_decomposition:
fixes A :: "complex mat"
assumes "A ∈ carrier_mat n n"
shows "∃B P es. similar_mat_wit A B P (adjoint P) ∧ unitary P
∧ char_poly A = (∏ (e :: complex) ← es. [:- e, 1:]) ∧ diag_mat B = es"
proof -
have "∃es. char_poly A = (∏ e ← es. [:- e, 1:]) ∧ length es = n"
using assms by (simp add: complex_mat_char_poly_factorizable)
then obtain es where es: "char_poly A = (∏ e ← es. [:- e, 1:]) ∧ length es = n" by auto
obtain B P Q where B: "unitary_schur_decomposition A es = (B,P,Q)" by (cases "unitary_schur_decomposition A es", auto)
have "similar_mat_wit A B P Q ∧ upper_triangular B ∧ unitary P ∧ (Q = adjoint P) ∧
char_poly A = (∏ (e :: complex) ← es. [:- e, 1:]) ∧ diag_mat B = es" using assms es B
by (auto simp add: unitary_schur_decomposition)
then show ?thesis by auto
qed
lemma normal_upper_triangular_matrix_is_diagonal:
fixes A :: "'a::conjugatable_ordered_field mat"
assumes "A ∈ carrier_mat n n"
and tri: "upper_triangular A"
and norm: "A * adjoint A = adjoint A * A"
shows "diagonal_mat A"
proof (rule disjE[of "n = 0" "n > 0"], blast)
have dim: "dim_row A = n" "dim_col A = n" using assms by auto
from norm have eq0: "⋀i j. (A * adjoint A)$$(i,j) = (adjoint A * A)$$(i,j)" by auto
have nat_induct_strong:
"⋀P. (P::nat⇒bool) 0 ⟹ (⋀i. i < n ⟹ (⋀k. k < i ⟹ P k) ⟹ P i) ⟹ (⋀i. i < n ⟹ P i)"
by (metis dual_order.strict_trans infinite_descent0 linorder_neqE_nat)
show "n = 0 ⟹ ?thesis" using dim unfolding diagonal_mat_def by auto
show "n > 0 ⟹ ?thesis" unfolding diagonal_mat_def dim
apply (rule allI, rule impI)
apply (rule nat_induct_strong)
proof (rule allI, rule impI, rule impI)
assume asm: "n > 0"
from tri upper_triangularD[of A 0 j] dim have z0: "⋀j. 0< j ⟹ j < n ⟹ A$$(j, 0) = 0"
by auto
then have ada00: "(adjoint A * A)$$(0,0) = conjugate (A$$(0,0)) * A$$(0,0)"
using asm dim by (auto simp add: scalar_prod_def adjoint_eval sum.atLeast_Suc_lessThan)
have aad00: "(A * adjoint A)$$(0,0) = (∑k=0..<n. A$$(0, k) * conjugate (A$$(0, k)))"
using asm dim by (auto simp add: scalar_prod_def adjoint_eval)
moreover have
"… = A$$(0,0) * conjugate (A$$(0,0))
+ (∑k=1..<n. A$$(0, k) * conjugate (A$$(0, k)))"
using dim asm by (subst sum.atLeast_Suc_lessThan[of 0 n "λk. A$$(0, k) * conjugate (A$$(0, k))"], auto)
ultimately have f1tneq0: "(∑k=(Suc 0)..<n. A$$(0, k) * conjugate (A$$(0, k))) = 0"
using eq0 ada00 by (simp)
have geq0: "⋀k. k < n ⟹ A$$(0, k) * conjugate (A$$(0, k)) ≥ 0"
using conjugate_square_positive by auto
have "⋀k. 1 ≤ k ⟹ k < n ⟹ A$$(0, k) * conjugate (A$$(0, k)) = 0"
by (rule sum_nonneg_0[of "{1..<n}"], auto, rule geq0, auto, rule f1tneq0)
with dim asm show
case0: "⋀j. 0 < n ⟹ j < n ⟹ 0 ≠ j ⟹ A $$ (0, j) = 0"
by auto
{
fix i
assume asm: "n > 0" "i < n" "i > 0"
and ih: "⋀k. k < i ⟹ ∀j<n. k ≠ j ⟶ A $$ (k, j) = 0"
then have "⋀j. j<n ⟹ i ≠ j ⟹ A $$ (i, j) = 0"
proof -
have inter_part: "⋀b m e. (b::nat) < e ⟹ b < m ⟹ m < e ⟹ {b..<m} ∪ {m..<e} = {b..<e}" by auto
then have
"⋀b m e f. (b::nat) < e ⟹ b < m ⟹ m < e
⟹ (∑k=b..<e. f k) = (∑k∈{b..<m}∪{m..<e}. f k)"
using sum.union_disjoint by auto
then have sum_part:
"⋀b m e f. (b::nat) < e ⟹ b < m ⟹ m < e
⟹ (∑k=b..<e. f k) = (∑k=b..<m. f k) + (∑k=m..<e. f k)"
by (auto simp add: sum.union_disjoint)
from tri upper_triangularD[of A j i] asm dim have
zsi0: "⋀j. j < i ⟹ A$$(i, j) = 0" by auto
from tri upper_triangularD[of A j i] asm dim have
zsi1: "⋀k. i < k ⟹ k < n ⟹ A$$(k, i) = 0" by auto
have
"(A * adjoint A)$$(i, i)
= (∑k=0..<n. conjugate (A$$(i, k)) * A$$(i, k))" using asm dim
apply (auto simp add: scalar_prod_def adjoint_eval)
apply (rule sum.cong, auto)
done
also have
"… = (∑k=0..<i. conjugate (A$$(i, k)) * A$$(i, k))
+ (∑k=i..<n. conjugate (A$$(i, k)) * A$$(i, k))"
using asm
by (auto simp add: sum_part[of 0 n i])
also have
"… = (∑k=i..<n. conjugate (A$$(i, k)) * A$$(i, k))"
using zsi0
by auto
also have
"… = conjugate (A$$(i, i)) * A$$(i, i)
+ (∑k=(Suc i)..<n. conjugate (A$$(i, k)) * A$$(i, k))"
using asm
by (auto simp add: sum.atLeast_Suc_lessThan)
finally have
adaii: "(A * adjoint A)$$(i, i)
= conjugate (A$$(i, i)) * A$$(i, i)
+ (∑k=(Suc i)..<n. conjugate (A$$(i, k)) * A$$(i, k))" .
have
"(adjoint A * A)$$(i, i) = (∑k=0..<n. conjugate (A$$(k, i)) * A$$(k, i))"
using asm dim by (auto simp add: scalar_prod_def adjoint_eval)
also have
"… = (∑k=0..<i. conjugate (A$$(k, i)) * A$$(k, i))
+ (∑k=i..<n. conjugate (A$$(k, i)) * A$$(k, i))"
using asm by (auto simp add: sum_part[of 0 n i])
also have
"… = (∑k=i..<n. conjugate (A$$(k, i)) * A$$(k, i))"
using asm ih by auto
also have
"… = conjugate (A$$(i, i)) * A$$(i, i)"
using asm zsi1 by (auto simp add: sum.atLeast_Suc_lessThan)
finally have "(adjoint A * A)$$(i, i) = conjugate (A$$(i, i)) * A$$(i, i)" .
with adaii eq0 have
fsitoneq0: "(∑k=(Suc i)..<n. conjugate (A$$(i, k)) * A$$(i, k)) = 0" by auto
have "⋀k. k<n ⟹ i < k ⟹ conjugate (A$$(i, k)) * A$$(i, k) = 0"
by (rule sum_nonneg_0[of "{(Suc i)..<n}"], auto, subst mult.commute,
rule conjugate_square_positive, rule fsitoneq0)
then have "⋀k. k<n ⟹ i<k ⟹ A $$ (i, k) = 0" by auto
with zsi0 show "⋀j. j<n ⟹ i ≠ j ⟹ A $$ (i, j) = 0"
by (metis linorder_neqE_nat)
qed
}
with case0 show "⋀i ia.
0 < n ⟹
i < n ⟹
ia < n ⟹
(⋀k. k < ia ⟹ ∀j<n. k ≠ j ⟶ A $$ (k, j) = 0) ⟹
∀j<n. ia ≠ j ⟶ A $$ (ia, j) = 0" by auto
qed
qed
lemma normal_complex_mat_has_spectral_decomposition:
assumes A: "(A::complex mat) ∈ carrier_mat n n"
and normal: "A * adjoint A = adjoint A * A"
and c: "char_poly A = (∏ (e :: complex) ← es. [:- e, 1:])"
and B: "unitary_schur_decomposition A es = (B,P,Q)"
shows "similar_mat_wit A B P (adjoint P) ∧ diagonal_mat B ∧ diag_mat B = es ∧ unitary P"
proof -
have smw: "similar_mat_wit A B P (adjoint P)"
and ut: "upper_triangular B"
and uP: "unitary P"
and dB: "diag_mat B = es"
and "(Q = adjoint P)"
using assms by (auto simp add: unitary_schur_decomposition)
from smw have dimP: "P ∈ carrier_mat n n" and dimB: "B ∈ carrier_mat n n"
and dimaP: "adjoint P ∈ carrier_mat n n"
unfolding similar_mat_wit_def using A by auto
have dimaB: "adjoint B ∈ carrier_mat n n" using dimB by auto
note dims = dimP dimB dimaP dimaB
have "inverts_mat P (adjoint P)" using unitary_def uP dims by auto
then have iaPP: "inverts_mat (adjoint P) P" using inverts_mat_symm using dims by auto
have aPP: "adjoint P * P = 1⇩m n" using dims iaPP unfolding inverts_mat_def by auto
from smw have A: "A = P * B * (adjoint P)" unfolding similar_mat_wit_def Let_def by auto
then have aA: "adjoint A = P * adjoint B * adjoint P"
by (insert A dimP dimB dimaP, auto simp add: adjoint_mult[of _ n n _ n] adjoint_adjoint)
have "A * adjoint A = (P * B * adjoint P) * (P * adjoint B * adjoint P)" using A aA by auto
also have "… = P * B * (adjoint P * P) * (adjoint B * adjoint P)" using dims by (mat_assoc n)
also have "… = P * B * 1⇩m n * (adjoint B * adjoint P)" using dims aPP by (auto)
also have "… = P * B * adjoint B * adjoint P" using dims by (mat_assoc n)
finally have "A * adjoint A = P * B * adjoint B * adjoint P".
then have "adjoint P * (A * adjoint A) * P = (adjoint P * P) * B * adjoint B * (adjoint P * P)"
using dims by (simp add: assoc_mult_mat[of _ n n _ n _ n])
also have "… = 1⇩m n * B * adjoint B * 1⇩m n" using aPP by auto
also have "… = B * adjoint B" using dims by auto
finally have eq0: "adjoint P * (A * adjoint A) * P = B * adjoint B".
have "adjoint A * A = (P * adjoint B * adjoint P) * (P * B * adjoint P)" using A aA by auto
also have "… = P * adjoint B * (adjoint P * P) * (B * adjoint P)" using dims by (mat_assoc n)
also have "… = P * adjoint B * 1⇩m n * (B * adjoint P)" using dims aPP by (auto)
also have "… = P * adjoint B * B * adjoint P" using dims by (mat_assoc n)
finally have "adjoint A * A = P * adjoint B * B * adjoint P" by auto
then have "adjoint P * (adjoint A * A) * P = (adjoint P * P) * adjoint B * B * (adjoint P * P)"
using dims by (simp add: assoc_mult_mat[of _ n n _ n _ n])
also have "… = 1⇩m n * adjoint B * B * 1⇩m n" using aPP by auto
also have "… = adjoint B * B" using dims by auto
finally have eq1: "adjoint P * (adjoint A * A) * P = adjoint B * B".
from normal have "adjoint P * (adjoint A * A) * P = adjoint P * (A * adjoint A) * P" by auto
with eq0 eq1 have "B * adjoint B = adjoint B * B" by auto
with ut dims have "diagonal_mat B" using normal_upper_triangular_matrix_is_diagonal by auto
with smw uP dB show "similar_mat_wit A B P (adjoint P) ∧ diagonal_mat B ∧ diag_mat B = es ∧ unitary P" by auto
qed
lemma complex_mat_has_jordan_nf:
fixes A :: "complex mat"
assumes "A ∈ carrier_mat n n"
shows "∃n_as. jordan_nf A n_as"
proof -
have "∃as. char_poly A = (∏ a ← as. [:- a, 1:]) ∧ length as = n"
using assms by (simp add: complex_mat_char_poly_factorizable)
then show ?thesis using assms
by (auto simp add: jordan_nf_iff_linear_factorization)
qed
lemma hermitian_is_normal:
assumes "hermitian A"
shows "A * adjoint A = adjoint A * A"
using assms by (auto simp add: hermitian_def)
lemma hermitian_eigenvalue_real:
assumes dim: "(A::complex mat) ∈ carrier_mat n n"
and hA: "hermitian A"
and c: "char_poly A = (∏ (e :: complex) ← es. [:- e, 1:])"
and B: "unitary_schur_decomposition A es = (B,P,Q)"
shows "similar_mat_wit A B P (adjoint P) ∧ diagonal_mat B ∧ diag_mat B = es
∧ unitary P ∧ (∀i < n. B$$(i, i) ∈ Reals)"
proof -
have normal: "A * adjoint A = adjoint A * A" using hA hermitian_is_normal by auto
then have schur: "similar_mat_wit A B P (adjoint P) ∧ diagonal_mat B ∧ diag_mat B = es ∧ unitary P"
using normal_complex_mat_has_spectral_decomposition[OF dim normal c B] by (simp)
then have "similar_mat_wit A B P (adjoint P)"
and uP: "unitary P" and dB: "diag_mat B = es"
using assms by auto
then have A: "A = P * B * (adjoint P)"
and dimB: "B ∈ carrier_mat n n" and dimP: "P ∈ carrier_mat n n"
unfolding similar_mat_wit_def Let_def using dim by auto
then have dimaB: "adjoint B ∈ carrier_mat n n" by auto
have "adjoint A = adjoint (adjoint P) * adjoint (P * B)"
apply (subst A)
apply (subst adjoint_mult[of "P * B" n n "adjoint P" n])
apply (insert dimB dimP, auto)
done
also have "… = P * adjoint (P * B)" by (auto simp add: adjoint_adjoint)
also have "… = P * (adjoint B * adjoint P)" using dimB dimP by (auto simp add: adjoint_mult)
also have "… = P * adjoint B * adjoint P" using dimB dimP by (subst assoc_mult_mat[symmetric, of P n n "adjoint B" n "adjoint P" n], auto)
finally have aA: "adjoint A = P * adjoint B * adjoint P" .
have "A = adjoint A" using hA hermitian_def[of A] by auto
then have "P * B * adjoint P = P * adjoint B * adjoint P" using A aA by auto
then have BaB: "B = adjoint B" using unitary_elim[OF dimB dimaB dimP] uP by auto
{
fix i
assume "i < n"
then have "B$$(i, i) = conjugate (B$$(i, i))"
apply (subst BaB)
by (insert dimB, simp add: adjoint_eval)
then have "B$$(i, i) ∈ Reals" unfolding conjugate_complex_def
using Reals_cnj_iff by auto
}
then have "∀i<n. B$$(i, i) ∈ Reals" by auto
with schur show ?thesis by auto
qed
lemma hermitian_inner_prod_real:
assumes dimA: "(A::complex mat) ∈ carrier_mat n n"
and dimv: "v ∈ carrier_vec n"
and hA: "hermitian A"
shows "inner_prod v (A *⇩v v) ∈ Reals"
proof -
obtain es where es: "char_poly A = (∏ (e :: complex) ← es. [:- e, 1:])"
using complex_mat_char_poly_factorizable dimA by auto
obtain B P Q where "unitary_schur_decomposition A es = (B,P,Q)"
by (cases "unitary_schur_decomposition A es", auto)
then have "similar_mat_wit A B P (adjoint P) ∧ diagonal_mat B ∧ diag_mat B = es
∧ unitary P ∧ (∀i < n. B$$(i, i) ∈ Reals)"
using hermitian_eigenvalue_real dimA es hA by auto
then have A: "A = P * B * (adjoint P)" and dB: "diagonal_mat B"
and Bii: "⋀i. i < n ⟹ B$$(i, i) ∈ Reals"
and dimB: "B ∈ carrier_mat n n" and dimP: "P ∈ carrier_mat n n" and dimaP: "adjoint P ∈ carrier_mat n n"
unfolding similar_mat_wit_def Let_def using dimA by auto
define w where "w = (adjoint P) *⇩v v"
then have dimw: "w ∈ carrier_vec n" using dimaP dimv by auto
from A have "inner_prod v (A *⇩v v) = inner_prod v ((P * B * (adjoint P)) *⇩v v)" by auto
also have "… = inner_prod v ((P * B) *⇩v ((adjoint P) *⇩v v))" using dimP dimB dimv
by (subst assoc_mult_mat_vec[of _ n n "adjoint P" n], auto)
also have "… = inner_prod v (P *⇩v (B *⇩v ((adjoint P) *⇩v v)))" using dimP dimB dimv dimaP
by (subst assoc_mult_mat_vec[of _ n n "B" n], auto)
also have "… = inner_prod w (B *⇩v w)" unfolding w_def
apply (rule adjoint_def_alter[OF _ _ dimP])
apply (insert mult_mat_vec_carrier[OF dimB mult_mat_vec_carrier[OF dimaP dimv]], auto simp add: dimv)
done
also have "… = (∑i=0..<n. (∑j=0..<n.
conjugate (w$i) * B$$(i, j) * w$j))" unfolding scalar_prod_def using dimw dimB
apply (simp add: scalar_prod_def sum_distrib_right)
apply (rule sum.cong, auto, rule sum.cong, auto)
done
also have "… = (∑i=0..<n. B$$(i, i) * conjugate (w$i) * w$i)"
apply (rule sum.cong, auto)
apply (simp add: sum.remove)
apply (insert dB[unfolded diagonal_mat_def] dimB, auto)
done
finally have sum: "inner_prod v (A *⇩v v) = (∑i=0..<n. B$$(i, i) * conjugate (w$i) * w$i)" .
have "⋀i. i < n ⟹ B$$(i, i) * conjugate (w$i) * w$i ∈ Reals" using Bii by (simp add: Reals_cnj_iff)
then have "(∑i=0..<n. B$$(i, i) * conjugate (w$i) * w$i) ∈ Reals" by auto
then show ?thesis using sum by auto
qed
lemma unit_vec_bracket:
fixes A :: "complex mat"
assumes dimA: "A ∈ carrier_mat n n" and i: "i < n"
shows "inner_prod (unit_vec n i) (A *⇩v (unit_vec n i)) = A$$(i, i)"
proof -
define w where "(w::complex vec) = unit_vec n i"
have "A *⇩v w = col A i" using i dimA w_def by auto
then have 1: "inner_prod w (A *⇩v w) = inner_prod w (col A i)" using w_def by auto
have "conjugate w = w" unfolding w_def unit_vec_def conjugate_vec_def using i by auto
then have 2: "inner_prod w (col A i) = A$$(i, i)" using i dimA w_def by auto
from 1 2 show "inner_prod w (A *⇩v w) = A$$(i, i)" by auto
qed
lemma spectral_decomposition_extract_diag:
fixes P B :: "complex mat"
assumes dimP: "P ∈ carrier_mat n n" and dimB: "B ∈ carrier_mat n n"
and uP: "unitary P" and dB: "diagonal_mat B" and i: "i < n"
shows "inner_prod (col P i) (P * B * (adjoint P) *⇩v (col P i)) = B$$(i, i)"
proof -
have dimaP: "adjoint P∈ carrier_mat n n" using dimP by auto
have uaP: "unitary (adjoint P)" using unitary_adjoint uP dimP by auto
then have "inverts_mat (adjoint P) P" by (simp add: unitary_def adjoint_adjoint)
then have iv: "(adjoint P) * P = 1⇩m n" using dimaP inverts_mat_def by auto
define v where "v = col P i"
then have dimv: "v ∈ carrier_vec n" using dimP by auto
define w where "(w::complex vec) = unit_vec n i"
then have dimw: "w ∈ carrier_vec n" by auto
have BaPv: "B *⇩v (adjoint P *⇩v v) ∈ carrier_vec n" using dimB dimaP dimv by auto
have "(adjoint P) *⇩v v = (col (adjoint P * P) i)"
by (simp add: col_mult2[OF dimaP dimP i, symmetric] v_def)
then have aPv: "(adjoint P) *⇩v v = w"
by (auto simp add: iv i w_def)
have "inner_prod v (P * B * (adjoint P) *⇩v v) = inner_prod v ((P * B) *⇩v ((adjoint P) *⇩v v))" using dimP dimB dimv
by (subst assoc_mult_mat_vec[of _ n n "adjoint P" n], auto)
also have "… = inner_prod v (P *⇩v (B *⇩v ((adjoint P) *⇩v v)))" using dimP dimB dimv dimaP
by (subst assoc_mult_mat_vec[of _ n n "B" n], auto)
also have "… = inner_prod (adjoint P *⇩v v) (B *⇩v (adjoint P *⇩v v))"
by (simp add: adjoint_def_alter[OF dimv BaPv dimP])
also have "… = inner_prod w (B *⇩v w)" using aPv by auto
also have "… = B$$(i, i)" using w_def unit_vec_bracket dimB i by auto
finally show "inner_prod v (P * B * (adjoint P) *⇩v v) = B$$(i, i)".
qed
lemma hermitian_inner_prod_zero:
fixes A :: "complex mat"
assumes dimA: "A ∈ carrier_mat n n" and hA: "hermitian A"
and zero: "∀v∈carrier_vec n. inner_prod v (A *⇩v v) = 0"
shows "A = 0⇩m n n"
proof -
obtain es where es: "char_poly A = (∏ (e :: complex) ← es. [:- e, 1:])"
using complex_mat_char_poly_factorizable dimA by auto
obtain B P Q where "unitary_schur_decomposition A es = (B,P,Q)"
by (cases "unitary_schur_decomposition A es", auto)
then have "similar_mat_wit A B P (adjoint P) ∧ diagonal_mat B ∧ diag_mat B = es
∧ unitary P ∧ (∀i < n. B$$(i, i) ∈ Reals)"
using hermitian_eigenvalue_real dimA es hA by auto
then have A: "A = P * B * (adjoint P)" and dB: "diagonal_mat B"
and Bii: "⋀i. i < n ⟹ B$$(i, i) ∈ Reals"
and dimB: "B ∈ carrier_mat n n" and dimP: "P ∈ carrier_mat n n" and dimaP: "adjoint P ∈ carrier_mat n n"
and uP: "unitary P"
unfolding similar_mat_wit_def Let_def unitary_def using dimA by auto
then have uaP: "unitary (adjoint P)" using unitary_adjoint by auto
then have "inverts_mat (adjoint P) P" by (simp add: unitary_def adjoint_adjoint)
then have iv: "adjoint P * P = 1⇩m n" using dimaP inverts_mat_def by auto
have "B = 0⇩m n n"
proof-
{
fix i assume i: "i < n"
define v where "v = col P i"
then have dimv: "v ∈ carrier_vec n" using v_def dimP by auto
have "inner_prod v (A *⇩v v) = B$$(i, i)" unfolding A v_def
using spectral_decomposition_extract_diag[OF dimP dimB uP dB i] by auto
moreover have "inner_prod v (A *⇩v v) = 0" using dimv zero by auto
ultimately have "B$$(i, i) = 0" by auto
}
note zB = this
show "B = 0⇩m n n" by (insert zB dB dimB, rule eq_matI, auto simp add: diagonal_mat_def)
qed
then show "A = 0⇩m n n" using A dimB dimP dimaP by auto
qed
lemma complex_mat_decomposition_to_hermitian:
fixes A :: "complex mat"
assumes dim: "A ∈ carrier_mat n n"
shows "∃B C. hermitian B ∧ hermitian C ∧ A = B + 𝗂 ⋅⇩m C ∧ B ∈ carrier_mat n n ∧ C ∈ carrier_mat n n"
proof -
obtain B C where B: "B = (1 / 2) ⋅⇩m (A + adjoint A)"
and C: "C = (-𝗂 / 2) ⋅⇩m (A - adjoint A)" by auto
then have dimB: "B ∈ carrier_mat n n" and dimC: "C ∈ carrier_mat n n" using dim by auto
have "hermitian B" unfolding B hermitian_def using dim
by (auto simp add: adjoint_eval)
moreover have "hermitian C" unfolding C hermitian_def using dim
apply (subst eq_matI)
apply (auto simp add: adjoint_eval algebra_simps)
done
moreover have "A = B + 𝗂 ⋅⇩m C" using dim B C
apply (subst eq_matI)
apply (auto simp add: adjoint_eval algebra_simps)
done
ultimately show ?thesis using dimB dimC by auto
qed
subsection ‹Outer product›
definition outer_prod :: "'a::conjugatable_field vec ⇒ 'a vec ⇒ 'a mat" where
"outer_prod v w = mat (dim_vec v) 1 (λ(i, j). v $ i) * mat 1 (dim_vec w) (λ(i, j). (conjugate w) $ j)"
lemma outer_prod_dim[simp]:
fixes v w :: "'a::conjugatable_field vec"
assumes v: "v ∈ carrier_vec n" and w: "w ∈ carrier_vec m"
shows "outer_prod v w ∈ carrier_mat n m"
unfolding outer_prod_def using assms mat_of_cols_carrier mat_of_rows_carrier by auto
lemma mat_of_vec_mult_eq_scalar_prod:
fixes v w :: "'a::conjugatable_field vec"
assumes "v ∈ carrier_vec n" and "w ∈ carrier_vec n"
shows "mat 1 (dim_vec v) (λ(i, j). (conjugate v) $ j) * mat (dim_vec w) 1 (λ(i, j). w $ i)
= mat 1 1 (λk. inner_prod v w)"
apply (rule eq_matI) using assms apply (simp add: scalar_prod_def) apply (rule sum.cong) by auto
lemma one_dim_mat_mult_is_scale:
fixes A B :: "('a::conjugatable_field mat)"
assumes "B ∈ carrier_mat 1 n"
shows "(mat 1 1 (λk. a)) * B = a ⋅⇩m B"
apply (rule eq_matI) using assms by (auto simp add: scalar_prod_def)
lemma outer_prod_mult_outer_prod:
fixes a b c d :: "'a::conjugatable_field vec"
assumes a: "a ∈ carrier_vec d1" and b: "b ∈ carrier_vec d2"
and c: "c ∈ carrier_vec d2" and d: "d ∈ carrier_vec d3"
shows "outer_prod a b * outer_prod c d = inner_prod b c ⋅⇩m outer_prod a d"
proof -
let ?ma = "mat (dim_vec a) 1 (λ(i, j). a $ i)"
let ?mb = "mat 1 (dim_vec b) (λ(i, j). (conjugate b) $ j)"
let ?mc = "mat (dim_vec c) 1 (λ(i, j). c $ i)"
let ?md = "mat 1 (dim_vec d) (λ(i, j). (conjugate d) $ j)"
have "(?ma * ?mb) * (?mc * ?md) = ?ma * (?mb * (?mc * ?md))"
apply (subst assoc_mult_mat[of "?ma" d1 1 "?mb" d2 "?mc * ?md" d3] )
using assms by auto
also have "… = ?ma * ((?mb * ?mc) * ?md)"
apply (subst assoc_mult_mat[symmetric, of "?mb" 1 d2 "?mc" 1 "?md" d3])
using assms by auto
also have "… = ?ma * ((mat 1 1 (λk. inner_prod b c)) * ?md)"
apply (subst mat_of_vec_mult_eq_scalar_prod[of b d2 c]) using assms by auto
also have "… = ?ma * (inner_prod b c ⋅⇩m ?md)"
apply (subst one_dim_mat_mult_is_scale) using assms by auto
also have "… = (inner_prod b c) ⋅⇩m (?ma * ?md)" using assms by auto
finally show ?thesis unfolding outer_prod_def by auto
qed
lemma index_outer_prod:
fixes v w :: "'a::conjugatable_field vec"
assumes v: "v ∈ carrier_vec n" and w: "w ∈ carrier_vec m"
and ij: "i < n" "j < m"
shows "(outer_prod v w)$$(i, j) = v $ i * conjugate (w $ j)"
unfolding outer_prod_def using assms by (simp add: scalar_prod_def)
lemma mat_of_vec_mult_vec:
fixes a b c :: "'a::conjugatable_field vec"
assumes a: "a ∈ carrier_vec d" and b: "b ∈ carrier_vec d"
shows "mat 1 d (λ(i, j). (conjugate a) $ j) *⇩v b = vec 1 (λk. inner_prod a b)"
apply (rule eq_vecI)
apply (simp add: scalar_prod_def carrier_vecD[OF a] carrier_vecD[OF b])
apply (rule sum.cong) by auto
lemma mat_of_vec_mult_one_dim_vec:
fixes a b :: "'a::conjugatable_field vec"
assumes a: "a ∈ carrier_vec d"
shows "mat d 1 (λ(i, j). a $ i) *⇩v vec 1 (λk. c) = c ⋅⇩v a"
apply (rule eq_vecI)
by (auto simp add: scalar_prod_def carrier_vecD[OF a])
lemma outer_prod_mult_vec:
fixes a b c :: "'a::conjugatable_field vec"
assumes a: "a ∈ carrier_vec d1" and b: "b ∈ carrier_vec d2"
and c: "c ∈ carrier_vec d2"
shows "outer_prod a b *⇩v c = inner_prod b c ⋅⇩v a"
proof -
have "outer_prod a b *⇩v c
= mat d1 1 (λ(i, j). a $ i)
* mat 1 d2 (λ(i, j). (conjugate b) $ j)
*⇩v c" unfolding outer_prod_def using assms by auto
also have "… = mat d1 1 (λ(i, j). a $ i)
*⇩v (mat 1 d2 (λ(i, j). (conjugate b) $ j)
*⇩v c)" apply (subst assoc_mult_mat_vec) using assms by auto
also have "… = mat d1 1 (λ(i, j). a $ i)
*⇩v vec 1 (λk. inner_prod b c)" using mat_of_vec_mult_vec[of b] assms by auto
also have "… = inner_prod b c ⋅⇩v a" using mat_of_vec_mult_one_dim_vec assms by auto
finally show ?thesis by auto
qed
lemma trace_outer_prod_right:
fixes A :: "'a::conjugatable_field mat" and v w :: "'a vec"
assumes A: "A ∈ carrier_mat n n"
and v: "v ∈ carrier_vec n" and w: "w ∈ carrier_vec n"
shows "trace (A * outer_prod v w) = inner_prod w (A *⇩v v)" (is "?lhs = ?rhs")
proof -
define B where "B = outer_prod v w"
then have B: "B ∈ carrier_mat n n" using assms by auto
have "trace(A * B) = (∑i = 0..<n. ∑j = 0..<n. A $$ (i,j) * B $$ (j,i))"
unfolding trace_def using A B by (simp add: scalar_prod_def)
also have "… = (∑i = 0..<n. ∑j = 0..<n. A $$ (i,j) * v $ j * conjugate (w $ i))"
unfolding B_def
apply (rule sum.cong, simp, rule sum.cong, simp)
by (insert v w, auto simp add: index_outer_prod)
finally have "?lhs = (∑i = 0..<n. ∑j = 0..<n. A $$ (i,j) * v $ j * conjugate (w $ i))" using B_def by auto
moreover have "?rhs = (∑i = 0..<n. ∑j = 0..<n. A $$ (i,j) * v $ j * conjugate (w $ i))" using A v w
by (simp add: scalar_prod_def sum_distrib_right)
ultimately show ?thesis by auto
qed
lemma trace_outer_prod:
fixes v w :: "('a::conjugatable_field vec)"
assumes v: "v ∈ carrier_vec n" and w: "w ∈ carrier_vec n"
shows "trace (outer_prod v w) = inner_prod w v" (is "?lhs = ?rhs")
proof -
have "(1⇩m n) * (outer_prod v w) = outer_prod v w" apply (subst left_mult_one_mat) using outer_prod_dim assms by auto
moreover have "1⇩m n *⇩v v = v" using assms by auto
ultimately show ?thesis using trace_outer_prod_right[of "1⇩m n" n v w] assms by auto
qed
lemma inner_prod_outer_prod:
fixes a b c d :: "'a::conjugatable_field vec"
assumes a: "a ∈ carrier_vec n" and b: "b ∈ carrier_vec n"
and c: "c ∈ carrier_vec m" and d: "d ∈ carrier_vec m"
shows "inner_prod a (outer_prod b c *⇩v d) = inner_prod a b * inner_prod c d" (is "?lhs = ?rhs")
proof -
define P where "P = outer_prod b c"
then have dimP: "P ∈ carrier_mat n m" using assms by auto
have "inner_prod a (P *⇩v d) = (∑i=0..<n. (∑j=0..<m. conjugate (a$i) * P$$(i, j) * d$j))" using assms dimP
apply (simp add: scalar_prod_def sum_distrib_right)
apply (rule sum.cong, auto)
apply (rule sum.cong, auto)
done
also have "… = (∑i=0..<n. (∑j=0..<m. conjugate (a$i) * b$i * conjugate(c$j) * d$j))"
using P_def b c by(simp add: index_outer_prod algebra_simps)
finally have eq: "?lhs = (∑i=0..<n. (∑j=0..<m. conjugate (a$i) * b$i * conjugate(c$j) * d$j))" using P_def by auto
have "?rhs = (∑i=0..<n. conjugate (a$i) * b$i) * (∑j=0..<m. conjugate(c$j) * d$j)" using assms
by (auto simp add: scalar_prod_def algebra_simps)
also have "… = (∑i=0..<n. (∑j=0..<m. conjugate (a$i) * b$i * conjugate(c$j) * d$j))"
using assms by (simp add: sum_product algebra_simps)
finally show "?lhs = ?rhs" using eq by auto
qed
subsection ‹Semi-definite matrices›
definition positive :: "complex mat ⇒ bool" where
"positive A ⟷
A ∈ carrier_mat (dim_col A) (dim_col A) ∧
(∀v. dim_vec v = dim_col A ⟶ inner_prod v (A *⇩v v) ≥ 0)"
lemma positive_iff_normalized_vec:
"positive A ⟷
A ∈ carrier_mat (dim_col A) (dim_col A) ∧
(∀v. (dim_vec v = dim_col A ∧ vec_norm v = 1) ⟶ inner_prod v (A *⇩v v) ≥ 0)"
proof (rule)
assume "positive A"
then show "A ∈ carrier_mat (dim_col A) (dim_col A) ∧
(∀v. dim_vec v = dim_col A ∧ vec_norm v = 1 ⟶ 0 ≤ inner_prod v (A *⇩v v))"
unfolding positive_def by auto
next
define n where "n = dim_col A"
assume "A ∈ carrier_mat (dim_col A) (dim_col A) ∧ (∀v. dim_vec v = dim_col A ∧ vec_norm v = 1 ⟶ 0 ≤ inner_prod v (A *⇩v v))"
then have A: "A ∈ carrier_mat (dim_col A) (dim_col A)" and geq0: "∀v. dim_vec v = dim_col A ∧ vec_norm v = 1 ⟶ 0 ≤ inner_prod v (A *⇩v v)" by auto
then have dimA: "A ∈ carrier_mat n n" using n_def[symmetric] by auto
{
fix v assume dimv: "(v::complex vec) ∈ carrier_vec n"
have "0 ≤ inner_prod v (A *⇩v v)"
proof (cases "v = 0⇩v n")
case True
then show "0 ≤ inner_prod v (A *⇩v v)" using dimA by auto
next
case False
then have 1: "vec_norm v > 0" using vec_norm_ge_0 dimv by auto
then have cnv: "cnj (vec_norm v) = vec_norm v" using Reals_cnj_iff complex_is_Real_iff by auto
define w where "w = vec_normalize v"
then have dimw: "w ∈ carrier_vec n" using dimv by auto
have nvw: "v = vec_norm v ⋅⇩v w" using w_def vec_eq_norm_smult_normalized by auto
have "vec_norm w = 1" using normalized_vec_norm[OF dimv False] vec_norm_def w_def by auto
then have 2: "0 ≤ inner_prod w (A *⇩v w)" using geq0 dimw dimA by auto
have "inner_prod v (A *⇩v v) = vec_norm v * vec_norm v * inner_prod w (A *⇩v w)" using dimA dimv dimw
apply (subst (1 2) nvw)
apply (subst mult_mat_vec, simp, simp)
apply (subst scalar_prod_smult_left[of "(A *⇩v w)" "conjugate (vec_norm v ⋅⇩v w)" "vec_norm v"], simp)
apply (simp add: conjugate_smult_vec cnv)
done
also have "… ≥ 0" using 1 2 by auto
finally show "0 ≤ inner_prod v (A *⇩v v)" by auto
qed
}
then have geq: "∀v. dim_vec v = dim_col A ⟶ 0 ≤ inner_prod v (A *⇩v v)" using dimA by auto
show "positive A" unfolding positive_def
by (rule, simp add: A, rule geq)
qed
lemma positive_is_hermitian:
fixes A :: "complex mat"
assumes pA: "positive A"
shows "hermitian A"
proof -
define n where "n = dim_col A"
then have dimA: "A ∈ carrier_mat n n" using positive_def pA by auto
obtain B C where B: "hermitian B" and C: "hermitian C" and A: "A = B + 𝗂 ⋅⇩m C"
and dimB: "B ∈ carrier_mat n n" and dimC: "C ∈ carrier_mat n n" and dimiC: "𝗂 ⋅⇩m C ∈ carrier_mat n n"
using complex_mat_decomposition_to_hermitian[OF dimA] by auto
{
fix v :: "complex vec" assume dimv: "v ∈ carrier_vec n"
have dimvA: "dim_vec v = dim_col A" using dimv dimA by auto
have "inner_prod v (A *⇩v v) = inner_prod v (B *⇩v v) + inner_prod v ((𝗂 ⋅⇩m C) *⇩v v)"
unfolding A using dimB dimiC dimv by (simp add: add_mult_distrib_mat_vec inner_prod_distrib_right)
moreover have "inner_prod v ((𝗂 ⋅⇩m C) *⇩v v) = 𝗂 * inner_prod v (C *⇩v v)" using dimv dimC
apply (simp add: scalar_prod_def sum_distrib_left cong: sum.cong)
apply (rule sum.cong, auto)
done
ultimately have ABC: "inner_prod v (A *⇩v v) = inner_prod v (B *⇩v v) + 𝗂 * inner_prod v (C *⇩v v)" by auto
moreover have "inner_prod v (B *⇩v v) ∈ Reals" using B dimB dimv hermitian_inner_prod_real by auto
moreover have "inner_prod v (C *⇩v v) ∈ Reals" using C dimC dimv hermitian_inner_prod_real by auto
moreover have "inner_prod v (A *⇩v v) ∈ Reals" using pA unfolding positive_def
apply (rule)
apply (fold n_def)
apply (simp add: complex_is_Real_iff[of "inner_prod v (A *⇩v v)"])
apply (auto simp add: dimvA)
done
ultimately have "inner_prod v (C *⇩v v) = 0" using of_real_Re by fastforce
}
then have "C = 0⇩m n n" using hermitian_inner_prod_zero dimC C by auto
then have "A = B" using A dimC dimB by auto
then show "hermitian A" using B by auto
qed
lemma positive_eigenvalue_positive:
assumes dimA: "(A::complex mat) ∈ carrier_mat n n"
and pA: "positive A"
and c: "char_poly A = (∏ (e :: complex) ← es. [:- e, 1:])"
and B: "unitary_schur_decomposition A es = (B,P,Q)"
shows "⋀i. i < n ⟹ B$$(i, i) ≥ 0"
proof -
have hA: "hermitian A" using positive_is_hermitian pA by auto
have "similar_mat_wit A B P (adjoint P) ∧ diagonal_mat B ∧ diag_mat B = es
∧ unitary P ∧ (∀i < n. B$$(i, i) ∈ Reals)"
using hermitian_eigenvalue_real dimA hA B c by auto
then have A: "A = P * B * (adjoint P)" and dB: "diagonal_mat B"
and Bii: "⋀i. i < n ⟹ B$$(i, i) ∈ Reals"
and dimB: "B ∈ carrier_mat n n" and dimP: "P ∈ carrier_mat n n" and dimaP: "adjoint P ∈ carrier_mat n n"
and uP: "unitary P"
unfolding similar_mat_wit_def Let_def unitary_def using dimA by auto
{
fix i assume i: "i < n"
define v where "v = col P i"
then have dimv: "v ∈ carrier_vec n" using v_def dimP by auto
have "inner_prod v (A *⇩v v) = B$$(i, i)" unfolding A v_def
using spectral_decomposition_extract_diag[OF dimP dimB uP dB i] by auto
moreover have "inner_prod v (A *⇩v v) ≥ 0" using dimv pA dimA positive_def by auto
ultimately show "B$$(i, i) ≥ 0" by auto
}
qed
lemma diag_mat_mult_diag_mat:
fixes B D :: "'a::semiring_0 mat"
assumes dimB: "B ∈ carrier_mat n n" and dimD: "D ∈ carrier_mat n n"
and dB: "diagonal_mat B" and dD: "diagonal_mat D"
shows "B * D = mat n n (λ(i,j). (if i = j then (B$$(i, i)) * (D$$(i, i)) else 0))"
proof(rule eq_matI, auto)
have Bij: "⋀x y. x < n ⟹ y < n ⟹ x ≠ y ⟹ B$$(x, y) = 0" using dB diagonal_mat_def dimB by auto
have Dij: "⋀x y. x < n ⟹ y < n ⟹ x ≠ y ⟹ D$$(x, y) = 0" using dD diagonal_mat_def dimD by auto
{
fix i j assume ij: "i < n" "j < n"
have "(B * D) $$ (i, j) = (∑k=0..<n. (B $$ (i, k)) * (D $$ (k, j)))" using dimB dimD
by (auto simp add: scalar_prod_def ij)
also have "… = B$$(i, i) * D$$(i, j)"
apply (simp add: sum.remove[of _i] ij)
apply (simp add: Bij Dij ij)
done
finally have "(B * D) $$ (i, j) = B$$(i, i) * D$$(i, j)".
}
note BDij = this
from BDij show "⋀j. j < n ⟹ (B * D) $$ (j, j) = B $$ (j, j) * D $$ (j, j)" by auto
from BDij show "⋀i j. i < n ⟹ j < n ⟹ i ≠ j ⟹ (B * D) $$ (i, j) = 0" using Bij Dij by auto
from assms show "dim_row B = n" "dim_col D = n" by auto
qed
lemma positive_only_if_decomp:
assumes dimA: "A ∈ carrier_mat n n" and pA: "positive A"
shows "∃M ∈ carrier_mat n n. M * adjoint M = A"
proof -
from pA have hA: "hermitian A" using positive_is_hermitian by auto
obtain es where es: "char_poly A = (∏ (e :: complex) ← es. [:- e, 1:])"
using complex_mat_char_poly_factorizable dimA by auto
obtain B P Q where schur: "unitary_schur_decomposition A es = (B,P,Q)"
by (cases "unitary_schur_decomposition A es", auto)
then have "similar_mat_wit A B P (adjoint P) ∧ diagonal_mat B ∧ diag_mat B = es
∧ unitary P ∧ (∀i < n. B$$(i, i) ∈ Reals)"
using hermitian_eigenvalue_real dimA es hA by auto
then have A: "A = P * B * (adjoint P)" and dB: "diagonal_mat B"
and Bii: "⋀i. i < n ⟹ B$$(i, i) ∈ Reals"
and dimB: "B ∈ carrier_mat n n" and dimP: "P ∈ carrier_mat n n" and dimaP: "adjoint P ∈ carrier_mat n n"
unfolding similar_mat_wit_def Let_def using dimA by auto
have Bii: "⋀i. i < n ⟹ B$$(i, i) ≥ 0" using pA dimA es schur positive_eigenvalue_positive by auto
define D where "D = mat n n (λ(i, j). (if (i = j) then csqrt (B$$(i, i)) else 0))"
then have dimD: "D ∈ carrier_mat n n" and dimaD: "adjoint D ∈ carrier_mat n n" using dimB by auto
have dD: "diagonal_mat D" using dB D_def unfolding diagonal_mat_def by auto
then have daD: "diagonal_mat (adjoint D)" by (simp add: adjoint_eval diagonal_mat_def)
have Dii: "⋀i. i < n ⟹ D$$(i, i) = csqrt (B$$(i, i))" using dimD D_def by auto
{
fix i assume i: "i < n"
define c where "c = csqrt (B$$(i, i))"
have c: "c ≥ 0" using Bii i c_def by auto
then have "conjugate c = c"
using Reals_cnj_iff complex_is_Real_iff by auto
then have "c * cnj c = B$$(i, i)" using c_def c unfolding conjugate_complex_def by (metis power2_csqrt power2_eq_square)
}
note cBii = this
have "D * adjoint D = mat n n (λ(i,j). (if (i = j) then B$$(i, i) else 0))"
apply (simp add: diag_mat_mult_diag_mat[OF dimD dimaD dD daD])
apply (rule eq_matI, auto simp add: D_def adjoint_eval cBii)
done
also have "… = B" using dimB dB[unfolded diagonal_mat_def] by auto
finally have DaDB: "D * adjoint D = B".
define M where "M = P * D"
then have dimM: "M ∈ carrier_mat n n" using dimP dimD by auto
have "M * adjoint M = (P * D) * (adjoint D * adjoint P)" using M_def adjoint_mult[OF dimP dimD] by auto
also have "… = P * (D * adjoint D) * (adjoint P)" using dimP dimD by (mat_assoc n)
also have "… = P * B * (adjoint P)" using DaDB by auto
finally have "M * adjoint M = A" using A by auto
with dimM show "∃M ∈ carrier_mat n n. M * adjoint M = A" by auto
qed
lemma positive_if_decomp:
assumes dimA: "A ∈ carrier_mat n n" and "∃M. M * adjoint M = A"
shows "positive A"
proof -
from assms obtain M where M: "M * adjoint M = A" by auto
define m where "m = dim_col M"
have dimM: "M ∈ carrier_mat n m" using M dimA m_def by auto
{
fix v assume dimv: "(v::complex vec) ∈ carrier_vec n"
have dimaM: "adjoint M ∈ carrier_mat m n" using dimM by auto
have dimaMv: "(adjoint M) *⇩v v ∈ carrier_vec m" using dimaM dimv by auto
have "inner_prod v (A *⇩v v) = inner_prod v (M * adjoint M *⇩v v)" using M by auto
also have "… = inner_prod v (M *⇩v (adjoint M *⇩v v))" using assoc_mult_mat_vec dimM dimaM dimv by auto
also have "… = inner_prod (adjoint M *⇩v v) (adjoint M *⇩v v)" using adjoint_def_alter[OF dimv dimaMv dimM] by auto
also have "… ≥ 0" using self_cscalar_prod_geq_0 by auto
finally have "inner_prod v (A *⇩v v) ≥ 0".
}
note geq0 = this
from dimA geq0 show "positive A" using positive_def by auto
qed
lemma positive_iff_decomp:
assumes dimA: "A ∈ carrier_mat n n"
shows "positive A ⟷ (∃M∈carrier_mat n n. M * adjoint M = A)"
proof
assume pA: "positive A"
then show "∃M∈carrier_mat n n. M * adjoint M = A" using positive_only_if_decomp assms by auto
next
assume "∃M∈carrier_mat n n. M * adjoint M = A"
then obtain M where M: "M * adjoint M = A" by auto
then show "positive A" using M positive_if_decomp assms by auto
qed
lemma positive_dim_eq:
assumes "positive A"
shows "dim_row A = dim_col A"
using carrier_matD(1)[of A "dim_col A" "dim_col A"] assms[unfolded positive_def] by simp
lemma positive_zero:
"positive (0⇩m n n)"
by (simp add: positive_def zero_mat_def mult_mat_vec_def scalar_prod_def)
lemma positive_one:
"positive (1⇩m n)"
proof (rule positive_if_decomp)
show "1⇩m n ∈ carrier_mat n n" by auto
have "adjoint (1⇩m n) = 1⇩m n" using hermitian_one hermitian_def by auto
then have "1⇩m n * adjoint (1⇩m n) = 1⇩m n" by auto
then show "∃M. M * adjoint M = 1⇩m n" by fastforce
qed
lemma positive_antisym:
assumes pA: "positive A" and pnA: "positive (-A)"
shows "A = 0⇩m (dim_col A) (dim_col A)"
proof -
define n where "n = dim_col A"
from pA have dimA: "A ∈ carrier_mat n n" and dimnA: "-A ∈ carrier_mat n n"
using positive_def n_def by auto
from pA have hA: "hermitian A" using positive_is_hermitian by auto
obtain es where es: "char_poly A = (∏ (e :: complex) ← es. [:- e, 1:])"
using complex_mat_char_poly_factorizable dimA by auto
obtain B P Q where schur: "unitary_schur_decomposition A es = (B,P,Q)"
by (cases "unitary_schur_decomposition A es", auto)
then have "similar_mat_wit A B P (adjoint P) ∧ diagonal_mat B ∧ unitary P"
using hermitian_eigenvalue_real dimA es hA by auto
then have A: "A = P * B * (adjoint P)" and dB: "diagonal_mat B" and uP: "unitary P"
and dimB: "B ∈ carrier_mat n n" and dimnB: "-B ∈ carrier_mat n n"
and dimP: "P ∈ carrier_mat n n" and dimaP: "adjoint P ∈ carrier_mat n n"
unfolding similar_mat_wit_def Let_def using dimA by auto
from es schur have geq0: "⋀i. i < n ⟹ B$$(i, i) ≥ 0" using positive_eigenvalue_positive dimA pA by auto
from A have nA: "-A = P * (-B) * (adjoint P)" using mult_smult_assoc_mat dimB dimP dimaP by auto
from dB have dnB: "diagonal_mat (-B)" by (simp add: diagonal_mat_def)
{
fix i assume i: "i < n"
define v where "v = col P i"
then have dimv: "v ∈ carrier_vec n" using v_def dimP by auto
have "inner_prod v ((-A) *⇩v v) = (-B)$$(i, i)" unfolding nA v_def
using spectral_decomposition_extract_diag[OF dimP dimnB uP dnB i] by auto
moreover have "inner_prod v ((-A) *⇩v v) ≥ 0" using dimv pnA dimnA positive_def by auto
ultimately have "B$$(i, i) ≤ 0" using dimB i by auto
moreover have "B$$(i, i) ≥ 0" using i geq0 by auto
ultimately have "B$$(i, i) = 0" by (metis no_atp(10))
}
then have "B = 0⇩m n n" using dimB dB[unfolded diagonal_mat_def]
by (subst eq_matI, auto)
then show "A = 0⇩m n n" using A dimB dimP dimaP by auto
qed
lemma positive_add:
assumes pA: "positive A" and pB: "positive B"
and dimA: "A ∈ carrier_mat n n" and dimB: "B ∈ carrier_mat n n"
shows "positive (A + B)"
unfolding positive_def
proof
have dimApB: "A + B ∈ carrier_mat n n" using dimA dimB by auto
then show "A + B ∈ carrier_mat (dim_col (A + B)) (dim_col (A + B))" using carrier_matD[of "A+B"] by auto
{
fix v assume dimv: "(v::complex vec) ∈ carrier_vec n"
have 1: "inner_prod v (A *⇩v v) ≥ 0" using dimv pA[unfolded positive_def] dimA by auto
have 2: "inner_prod v (B *⇩v v) ≥ 0" using dimv pB[unfolded positive_def] dimB by auto
have "inner_prod v ((A + B) *⇩v v) = inner_prod v (A *⇩v v) + inner_prod v (B *⇩v v)"
using dimA dimB dimv by (simp add: add_mult_distrib_mat_vec inner_prod_distrib_right)
also have "… ≥ 0" using 1 2 by auto
finally have "inner_prod v ((A + B) *⇩v v) ≥ 0".
}
note geq0 = this
then have "⋀v. dim_vec v = n ⟹ 0 ≤ inner_prod v ((A + B) *⇩v v)" by auto
then show "∀v. dim_vec v = dim_col (A + B) ⟶ 0 ≤ inner_prod v ((A + B) *⇩v v)" using dimApB by auto
qed
lemma positive_trace:
assumes "A ∈ carrier_mat n n" and "positive A"
shows "trace A ≥ 0"
using assms positive_iff_decomp trace_adjoint_positive by auto
lemma positive_close_under_left_right_mult_adjoint:
fixes M A :: "complex mat"
assumes dM: "M ∈ carrier_mat n n" and dA: "A ∈ carrier_mat n n"
and pA: "positive A"
shows "positive (M * A * adjoint M)"
unfolding positive_def
proof (rule, simp add: mult_carrier_mat[OF mult_carrier_mat[OF dM dA] adjoint_dim[OF dM]] carrier_matD[OF dM], rule, rule)
have daM: "adjoint M ∈ carrier_mat n n" using dM by auto
fix v::"complex vec" assume "dim_vec v = dim_col (M * A * adjoint M)"
then have dv: "v ∈ carrier_vec n" using assms by auto
then have "adjoint M *⇩v v ∈ carrier_vec n" using daM by auto
have assoc: "M * A * adjoint M *⇩v v = M *⇩v (A *⇩v (adjoint M *⇩v v))"
using dA dM daM dv by (auto simp add: assoc_mult_mat_vec[of _ n n _ n])
have "inner_prod v (M * A * adjoint M *⇩v v) = inner_prod (adjoint M *⇩v v) (A *⇩v (adjoint M *⇩v v))"
apply (subst assoc)
apply (subst adjoint_def_alter[where ?A = "M"])
by (auto simp add: dv dA daM dM carrier_matD[OF dM] mult_mat_vec_carrier[of _ n n])
also have "… ≥ 0" using dA dv daM pA positive_def by auto
finally show "inner_prod v (M * A * adjoint M *⇩v v) ≥ 0" by auto
qed
lemma positive_same_outer_prod:
fixes v w :: "complex vec"
assumes v: "v ∈ carrier_vec n"
shows "positive (outer_prod v v)"
proof -
have d1: "adjoint (mat (dim_vec v) 1 (λ(i, j). v $ i)) ∈ carrier_mat 1 n" using assms by auto
have d2: "mat 1 (dim_vec v) (λ(i, y). conjugate v $ y) ∈ carrier_mat 1 n" using assms by auto
have dv: "dim_vec v = n" using assms by auto
have "mat 1 (dim_vec v) (λ(i, y). conjugate v $ y) = adjoint (mat (dim_vec v) 1 (λ(i, j). v $ i))" (is "?r = adjoint ?l")
apply (rule eq_matI)
subgoal for i j by (simp add: dv adjoint_eval)
using d1 d2 by auto
then have "outer_prod v v = ?l * adjoint ?l" unfolding outer_prod_def by auto
then have "∃M. M * adjoint M = outer_prod v v" by auto
then show "positive (outer_prod v v)" using positive_if_decomp[OF outer_prod_dim[OF v v]] by auto
qed
lemma smult_smult_mat:
fixes k :: complex and l :: complex
assumes "A ∈ carrier_mat nr n"
shows "k ⋅⇩m (l ⋅⇩m A) = (k * l) ⋅⇩m A" by auto
lemma positive_smult:
assumes "A ∈ carrier_mat n n"
and "positive A"
and "c ≥ 0"
shows "positive (c ⋅⇩m A)"
proof -
have sc: "csqrt c ≥ 0" using assms(3) by fastforce
obtain M where dimM: "M ∈ carrier_mat n n" and A: "M * adjoint M = A" using assms(1-2) positive_iff_decomp by auto
have "c ⋅⇩m A = c ⋅⇩m (M * adjoint M)" using A by auto
have ccsq: "conjugate (csqrt c) = (csqrt c)" using sc Reals_cnj_iff[of "csqrt c"] complex_is_Real_iff by auto
have MM: "(M * adjoint M) ∈ carrier_mat n n" using A assms by fastforce
have leftd: "c ⋅⇩m (M * adjoint M) ∈ carrier_mat n n" using A assms by fastforce
have rightd: "(csqrt c ⋅⇩m M) * (adjoint (csqrt c ⋅⇩m M))∈ carrier_mat n n" using A assms by fastforce
have "(csqrt c ⋅⇩m M) * (adjoint (csqrt c ⋅⇩m M)) = (csqrt c ⋅⇩m M) * ((conjugate (csqrt c)) ⋅⇩m adjoint M)"
using adjoint_scale assms(1) by (metis adjoint_scale)
also have "… = (csqrt c ⋅⇩m M) * (csqrt c ⋅⇩m adjoint M)" using sc ccsq by fastforce
also have "… = csqrt c ⋅⇩m (M * (csqrt c ⋅⇩m adjoint M))"
using mult_smult_assoc_mat index_smult_mat(2,3) by fastforce
also have "… = csqrt c ⋅⇩m ((csqrt c) ⋅⇩m (M * adjoint M))"
using mult_smult_distrib by fastforce
also have "… = c ⋅⇩m (M * adjoint M)"
using smult_smult_mat[of "M * adjoint M" n n "(csqrt c)" "(csqrt c)"] MM sc
by (metis power2_csqrt power2_eq_square )
also have "… = c ⋅⇩m A" using A by auto
finally have "(csqrt c ⋅⇩m M) * (adjoint (csqrt c ⋅⇩m M)) = c ⋅⇩m A" by auto
moreover have "c ⋅⇩m A ∈ carrier_mat n n" using assms(1) by auto
moreover have "csqrt c ⋅⇩m M ∈ carrier_mat n n" using dimM by auto
ultimately show ?thesis using positive_iff_decomp by auto
qed
text ‹Version of previous theorem for real numbers›
lemma positive_scale:
fixes c :: real
assumes "A ∈ carrier_mat n n"
and "positive A"
and "c ≥ 0"
shows "positive (c ⋅⇩m A)"
apply (rule positive_smult) using assms by auto
subsection ‹L\"{o}wner partial order›
definition lowner_le :: "complex mat ⇒ complex mat ⇒ bool" (infix "≤⇩L" 50) where
"A ≤⇩L B ⟷ dim_row A = dim_row B ∧ dim_col A = dim_col B ∧ positive (B - A)"
lemma lowner_le_refl:
assumes "A ∈ carrier_mat n n"
shows "A ≤⇩L A"
unfolding lowner_le_def
apply (simp add: minus_r_inv_mat[OF assms])
by (rule positive_zero)
lemma lowner_le_antisym:
assumes A: "A ∈ carrier_mat n n" and B: "B ∈ carrier_mat n n"
and L1: "A ≤⇩L B" and L2: "B ≤⇩L A"
shows "A = B"
proof -
from L1 have P1: "positive (B - A)" by (simp add: lowner_le_def)
from L2 have P2: "positive (A - B)" by (simp add: lowner_le_def)
have "A - B = - (B - A)" using A B by auto
then have P3: "positive (- (B - A))" using P2 by auto
have BA: "B - A ∈ carrier_mat n n" using A B by auto
have "B - A = 0⇩m n n" using BA by (subst positive_antisym[OF P1 P3], auto)
then have "B + (-A) + A = 0⇩m n n + A" using A B minus_add_uminus_mat[OF B A] by auto
then have "B + (-A + A) = 0⇩m n n + A" using A B by auto
then show "A = B" using A B BA uminus_l_inv_mat[OF A] by auto
qed
lemma lowner_le_inner_prod_le:
fixes A B :: "complex mat" and v :: "complex vec"
assumes A: "A ∈ carrier_mat n n" and B: "B ∈ carrier_mat n n"
and v: "v ∈ carrier_vec n"
and "A ≤⇩L B"
shows "inner_prod v (A *⇩v v) ≤ inner_prod v (B *⇩v v)"
proof -
from assms have "positive (B-A)" by (auto simp add: lowner_le_def)
with assms have geq: "inner_prod v ((B-A) *⇩v v) ≥ 0"
unfolding positive_def by auto
have "inner_prod v ((B-A) *⇩v v) = inner_prod v (B *⇩v v) - inner_prod v (A *⇩v v)"
unfolding minus_add_uminus_mat[OF B A]
by (subst add_mult_distrib_mat_vec[OF B _ v], insert A B v, auto simp add: inner_prod_distrib_right[OF v])
then show ?thesis using geq by auto
qed
lemma lowner_le_trans:
fixes A B C :: "complex mat"
assumes A: "A ∈ carrier_mat n n" and B: "B ∈ carrier_mat n n" and C: "C ∈ carrier_mat n n"
and L1: "A ≤⇩L B" and L2: "B ≤⇩L C"
shows "A ≤⇩L C"
unfolding lowner_le_def
proof (auto simp add: carrier_matD[OF A] carrier_matD[OF C])
have dim: "C - A ∈ carrier_mat n n" using A C by auto
{
fix v assume v: "(v::complex vec) ∈ carrier_vec n"
from L1 have "inner_prod v (A *⇩v v) ≤ inner_prod v (B *⇩v v)" using lowner_le_inner_prod_le A B v by auto
also from L2 have "… ≤ inner_prod v (C *⇩v v)" using lowner_le_inner_prod_le B C v by auto
finally have "inner_prod v (A *⇩v v) ≤ inner_prod v (C *⇩v v)".
then have "inner_prod v (C *⇩v v) - inner_prod v (A *⇩v v) ≥ 0" by auto
then have "inner_prod v ((C - A) *⇩v v) ≥ 0" using A C v
apply (subst minus_add_uminus_mat[OF C A])
apply (subst add_mult_distrib_mat_vec[OF C _ v], simp)
apply (simp add: inner_prod_distrib_right[OF v])
done
}
note leq = this
show "positive (C - A)" unfolding positive_def
apply (rule, simp add: carrier_matD[OF A] dim)
apply (subst carrier_matD[OF dim], insert leq, auto)
done
qed
lemma lowner_le_imp_trace_le:
assumes "A ∈ carrier_mat n n" and "B ∈ carrier_mat n n"
and "A ≤⇩L B"
shows "trace A ≤ trace B"
proof -
have "positive (B - A)" using assms lowner_le_def by auto
moreover have "B - A ∈ carrier_mat n n" using assms by auto
ultimately have "trace (B - A) ≥ 0" using positive_trace by auto
moreover have "trace (B - A) = trace B - trace A" using trace_minus_linear assms by auto
ultimately have "trace B - trace A ≥ 0" by auto
then show "trace A ≤ trace B" by auto
qed
lemma lowner_le_add:
assumes "A ∈ carrier_mat n n" "B ∈ carrier_mat n n" "C ∈ carrier_mat n n" "D ∈ carrier_mat n n"
and "A ≤⇩L B" "C ≤⇩L D"
shows "A + C ≤⇩L B + D"
proof -
have "B + D - (A + C) = B - A + (D - C) " using assms by auto
then have "positive (B + D - (A + C))" using assms unfolding lowner_le_def using positive_add
by (metis minus_carrier_mat)
then show "A + C ≤⇩L B + D" unfolding lowner_le_def using assms by fastforce
qed
lemma lowner_le_swap:
assumes "A ∈ carrier_mat n n" "B ∈ carrier_mat n n"
and "A ≤⇩L B"
shows "-B ≤⇩L -A"
proof -
have "positive (B - A)" using assms lowner_le_def by fastforce
moreover have "B - A = (-A) - (-B)" using assms by fastforce
ultimately have "positive ((-A) - (-B))" by auto
then show ?thesis using lowner_le_def assms by fastforce
qed
lemma lowner_le_minus:
assumes "A ∈ carrier_mat n n" "B ∈ carrier_mat n n" "C ∈ carrier_mat n n" "D ∈ carrier_mat n n"
and "A ≤⇩L B" "C ≤⇩L D"
shows "A - D ≤⇩L B - C"
proof -
have "positive (D - C)" using assms lowner_le_def by auto
then have "-D ≤⇩L -C" using lowner_le_swap assms by auto
then have "A + (-D) ≤⇩L B + (-C)" using lowner_le_add[of "A" n "B"] assms by auto
moreover have "A + (-D) = A - D" and "B + (-C) = B - C" by auto
ultimately show ?thesis by auto
qed
lemma outer_prod_le_one:
assumes "v ∈ carrier_vec n"
and "inner_prod v v ≤ 1"
shows "outer_prod v v ≤⇩L 1⇩m n"
proof -
let ?o = "outer_prod v v"
have do: "?o ∈ carrier_mat n n" using assms by auto
{
fix u :: "complex vec" assume "dim_vec u = n"
then have du: "u ∈ carrier_vec n" by auto
have r: "inner_prod u u ∈ Reals" apply (simp add: scalar_prod_def carrier_vecD[OF du])
using complex_In_mult_cnj_zero complex_is_Real_iff by blast
have geq0: "inner_prod u u ≥ 0"
using self_cscalar_prod_geq_0 by auto
have "inner_prod u (?o *⇩v u) = inner_prod u v * inner_prod v u"
apply (subst inner_prod_outer_prod)
using du assms by auto
also have "… ≤ inner_prod u u * inner_prod v v" using Cauchy_Schwarz_complex_vec du assms by auto
also have "… ≤ inner_prod u u" using assms(2) r geq0
by (simp add: mult_right_le_one_le)
finally have le: "inner_prod u (?o *⇩v u) ≤ inner_prod u u".
have "inner_prod u ((1⇩m n - ?o) *⇩v u) = inner_prod u ((1⇩m n *⇩v u) - ?o *⇩v u)"
apply (subst minus_mult_distrib_mat_vec) using do du by auto
also have "… = inner_prod u u - inner_prod u (?o *⇩v u)"
apply (subst inner_prod_minus_distrib_right)
using du do by auto
also have "… ≥ 0" using le by auto
finally have "inner_prod u ((1⇩m n - ?o) *⇩v u) ≥ 0" by auto
}
then have "positive (1⇩m n - outer_prod v v)"
unfolding positive_def using do by auto
then show ?thesis unfolding lowner_le_def using do by auto
qed
lemma zero_lowner_le_positiveD:
fixes A :: "complex mat"
assumes dA: "A ∈ carrier_mat n n" and le: "0⇩m n n ≤⇩L A"
shows "positive A"
using assms unfolding lowner_le_def by (subgoal_tac "A - 0⇩m n n = A", auto)
lemma zero_lowner_le_positiveI:
fixes A :: "complex mat"
assumes dA: "A ∈ carrier_mat n n" and le: "positive A"
shows "0⇩m n n ≤⇩L A"
using assms unfolding lowner_le_def by (subgoal_tac "A - 0⇩m n n = A", auto)
lemma lowner_le_trans_positiveI:
fixes A B :: "complex mat"
assumes dA: "A ∈ carrier_mat n n" and pA: "positive A" and le: "A ≤⇩L B"
shows "positive B"
proof -
have dB: "B ∈ carrier_mat n n" using le dA lowner_le_def by auto
have "0⇩m n n ≤⇩L A" using zero_lowner_le_positiveI dA pA by auto
then have "0⇩m n n ≤⇩L B" using dA dB le by (simp add: lowner_le_trans[of _ n A B])
then show ?thesis using dB zero_lowner_le_positiveD by auto
qed
lemma lowner_le_keep_under_measurement:
fixes M A B :: "complex mat"
assumes dM: "M ∈ carrier_mat n n" and dA: "A ∈ carrier_mat n n" and dB: "B ∈ carrier_mat n n"
and le: "A ≤⇩L B"
shows "adjoint M * A * M ≤⇩L adjoint M * B * M"
unfolding lowner_le_def
proof (rule conjI, fastforce)+
have daM: "adjoint M ∈ carrier_mat n n" using dM by auto
have dBmA: "B - A ∈ carrier_mat n n" using dB dA by fastforce
have "positive (B - A)" using le lowner_le_def by auto
then have p: "positive (adjoint M * (B - A) * M)"
using positive_close_under_left_right_mult_adjoint[OF daM dBmA] adjoint_adjoint[of M] by auto
moreover have e: "adjoint M * (B - A) * M = adjoint M * B * M - adjoint M * A * M" using dM dB dA by (mat_assoc n)
ultimately show "positive (adjoint M * B * M - adjoint M * A * M)" by auto
qed
lemma smult_distrib_left_minus_mat:
fixes A B :: "'a::comm_ring_1 mat"
assumes "A ∈ carrier_mat n n" "B ∈ carrier_mat n n"
shows "c ⋅⇩m (B - A) = c ⋅⇩m B - c ⋅⇩m A"
using assms by (auto simp add: minus_add_uminus_mat add_smult_distrib_left_mat)
lemma lowner_le_smultc:
fixes c :: complex
assumes "c ≥ 0" "A ≤⇩L B" "A ∈ carrier_mat n n" "B ∈ carrier_mat n n"
shows "c ⋅⇩m A ≤⇩L c ⋅⇩m B"
proof -
have eqBA: "c ⋅⇩m (B - A) = c ⋅⇩m B - c ⋅⇩m A"
using assms by (auto simp add: smult_distrib_left_minus_mat)
have "positive (B - A)" using assms(2) unfolding lowner_le_def by auto
then have "positive (c ⋅⇩m (B - A))" using positive_smult[of "B-A" n c] assms by fastforce
moreover have "c ⋅⇩m A ∈ carrier_mat n n" using index_smult_mat(2,3) assms(3) by auto
moreover have "c ⋅⇩m B ∈ carrier_mat n n" using index_smult_mat(2,3) assms(4) by auto
ultimately show ?thesis unfolding lowner_le_def using eqBA by fastforce
qed
lemma lowner_le_smult:
fixes c :: real
assumes "c ≥ 0" "A ≤⇩L B" "A ∈ carrier_mat n n" "B ∈ carrier_mat n n"
shows "c ⋅⇩m A ≤⇩L c ⋅⇩m B"
apply (rule lowner_le_smultc) using assms by auto
lemma minus_smult_vec_distrib:
fixes w :: "'a::comm_ring_1 vec"
shows "(a - b) ⋅⇩v w = a ⋅⇩v w - b ⋅⇩v w"
apply (rule eq_vecI)
by (auto simp add: scalar_prod_def algebra_simps)
lemma smult_mat_mult_mat_vec_assoc:
fixes A :: "'a::comm_ring_1 mat"
assumes A: "A ∈ carrier_mat n m" and w: "w ∈ carrier_vec m"
shows "a ⋅⇩m A *⇩v w = a ⋅⇩v (A *⇩v w)"
apply (rule eq_vecI)
apply (simp add: scalar_prod_def carrier_matD[OF A] carrier_vecD[OF w])
apply (subst sum_distrib_left) apply (rule sum.cong, simp)
by auto
lemma mult_mat_vec_smult_vec_assoc:
fixes A :: "'a::comm_ring_1 mat"
assumes A: "A ∈ carrier_mat n m" and w: "w ∈ carrier_vec m"
shows "A *⇩v (a ⋅⇩v w) = a ⋅⇩v (A *⇩v w)"
apply (rule eq_vecI)
apply (simp add: scalar_prod_def carrier_matD[OF A] carrier_vecD[OF w])
apply (subst sum_distrib_left) apply (rule sum.cong, simp)
by auto
lemma outer_prod_left_right_mat:
fixes A B :: "complex mat"
assumes du: "u ∈ carrier_vec d2" and dv: "v ∈ carrier_vec d3"
and dA: "A ∈ carrier_mat d1 d2" and dB: "B ∈ carrier_mat d3 d4"
shows "A * (outer_prod u v) * B = (outer_prod (A *⇩v u) (adjoint B *⇩v v))"
unfolding outer_prod_def
proof -
have eq1: "A * (mat (dim_vec u) 1 (λ(i, j). u $ i)) = mat (dim_vec (A *⇩v u)) 1 (λ(i, j). (A *⇩v u) $ i)"
apply (rule eq_matI)
by (auto simp add: dA du scalar_prod_def)
have conj: "conjugate a * b = conjugate ((a::complex) * conjugate b) " for a b by auto
have eq2: "mat 1 (dim_vec v) (λ(i, y). conjugate v $ y) * B = mat 1 (dim_vec (adjoint B *⇩v v)) (λ(i, y). conjugate (adjoint B *⇩v v) $ y)"
apply (rule eq_matI)
apply (auto simp add: carrier_matD[OF dB] carrier_vecD[OF dv] scalar_prod_def adjoint_def conjugate_vec_def sum_conjugate )
apply (rule sum.cong)
by (auto simp add: conj)
have "A * (mat (dim_vec u) 1 (λ(i, j). u $ i) * mat 1 (dim_vec v) (λ(i, y). conjugate v $ y)) * B =
(A * (mat (dim_vec u) 1 (λ(i, j). u $ i))) *(mat 1 (dim_vec v) (λ(i, y). conjugate v $ y)) * B"
using dA du dv dB assoc_mult_mat[OF dA, of "mat (dim_vec u) 1 (λ(i, j). u $ i)" 1 "mat 1 (dim_vec v) (λ(i, y). conjugate v $ y)"] by fastforce
also have "… = (A * (mat (dim_vec u) 1 (λ(i, j). u $ i))) *((mat 1 (dim_vec v) (λ(i, y). conjugate v $ y)) * B)"
using dA du dv dB assoc_mult_mat[OF _ _ dB, of "(A * (mat (dim_vec u) 1 (λ(i, j). u $ i)))" d1 1] by fastforce
finally show "A * (mat (dim_vec u) 1 (λ(i, j). u $ i) * mat 1 (dim_vec v) (λ(i, y). conjugate v $ y)) * B =
mat (dim_vec (A *⇩v u)) 1 (λ(i, j). (A *⇩v u) $ i) * mat 1 (dim_vec (adjoint B *⇩v v)) (λ(i, y). conjugate (adjoint B *⇩v v) $ y)"
using eq1 eq2 by auto
qed
subsection ‹Density operators›
definition density_operator :: "complex mat ⇒ bool" where
"density_operator A ⟷ positive A ∧ trace A = 1"
definition partial_density_operator :: "complex mat ⇒ bool" where
"partial_density_operator A ⟷ positive A ∧ trace A ≤ 1"
lemma pure_state_self_outer_prod_is_partial_density_operator:
fixes v :: "complex vec"
assumes dimv: "v ∈ carrier_vec n" and nv: "vec_norm v = 1"
shows "partial_density_operator (outer_prod v v)"
unfolding partial_density_operator_def
proof
have dimov: "outer_prod v v ∈ carrier_mat n n" using dimv by auto
show "positive (outer_prod v v)" unfolding positive_def
proof (rule, simp add: carrier_matD(2)[OF dimov] dimov, rule allI, rule impI)
fix w assume "dim_vec (w::complex vec) = dim_col (outer_prod v v)"
then have dimw: "w ∈ carrier_vec n" using dimov carrier_vecI by auto
then have "inner_prod w ((outer_prod v v) *⇩v w) = inner_prod w v * inner_prod v w"
using inner_prod_outer_prod dimw dimv by auto
also have "… = inner_prod w v * conjugate (inner_prod w v)" using dimw dimv
apply (subst conjugate_scalar_prod[of v "conjugate w"], simp)
apply (subst conjugate_vec_sprod_comm[of "conjugate v" _ "conjugate w"], auto)
apply (rule carrier_vec_conjugate[OF dimv])
apply (rule carrier_vec_conjugate[OF dimw])
done
also have "… ≥ 0" by auto
finally show "inner_prod w ((outer_prod v v) *⇩v w) ≥ 0".
qed
have eq: "trace (outer_prod v v) = (∑i=0..<n. v$i * conjugate(v$i))" unfolding trace_def
apply (subst carrier_matD(1)[OF dimov])
apply (simp add: index_outer_prod[OF dimv dimv])
done
have "vec_norm v = csqrt (∑i=0..<n. v$i * conjugate(v$i))" unfolding vec_norm_def using dimv
by (simp add: scalar_prod_def)
then have "(∑i=0..<n. v$i * conjugate(v$i)) = 1" using nv by auto
with eq show "trace (outer_prod v v) ≤ 1" by auto
qed
lemma lowner_le_trace:
assumes A: "A ∈ carrier_mat n n"
and B: "B ∈ carrier_mat n n"
shows "A ≤⇩L B ⟷ (∀ρ∈carrier_mat n n. partial_density_operator ρ ⟶ trace (A * ρ) ≤ trace (B * ρ))"
proof (rule iffI)
have dimBmA: "B - A ∈ carrier_mat n n" using A B by auto
{
assume "A ≤⇩L B"
then have pBmA: "positive (B - A)" using lowner_le_def by auto
moreover have "B - A ∈ carrier_mat n n" using assms by auto
ultimately have "∃M∈carrier_mat n n. M * adjoint M = B - A" using positive_iff_decomp[of "B - A"] by auto
then obtain M where dimM: "M ∈ carrier_mat n n" and M: "M * adjoint M = B - A" by auto
{
fix ρ assume dimr: "ρ ∈ carrier_mat n n" and pdr: "partial_density_operator ρ"
have eq: "trace(B * ρ) - trace(A * ρ) = trace((B - A) * ρ)" using A B dimr
apply (subst minus_mult_distrib_mat, auto)
apply (subst trace_minus_linear, auto)
done
have pr: "positive ρ" using pdr partial_density_operator_def by auto
then have "∃P∈carrier_mat n n. ρ = P * adjoint P" using positive_iff_decomp dimr by auto
then obtain P where dimP: "P ∈ carrier_mat n n" and P: "ρ = P * adjoint P" by auto
have "trace((B - A) * ρ) = trace(M * adjoint M * (P * adjoint P))" using P M by auto
also have "… = trace((adjoint P * M) * adjoint (adjoint P * M))" using dimM dimP by (mat_assoc n)
also have "… ≥ 0" using trace_adjoint_positive by auto
finally have "trace((B - A) * ρ) ≥ 0".
with eq have " trace (B * ρ) - trace (A * ρ) ≥ 0" by auto
}
then show "∀ρ∈carrier_mat n n. partial_density_operator ρ ⟶ trace (A * ρ) ≤ trace (B * ρ)" by auto
}
{
assume asm: "∀ρ∈carrier_mat n n. partial_density_operator ρ ⟶ trace (A * ρ) ≤ trace (B * ρ)"
have "positive (B - A)"
proof -
{
fix v assume "dim_vec (v::complex vec) = dim_col (B - A) ∧ vec_norm v = 1"
then have dimv: "v ∈ carrier_vec n" and nv: "vec_norm v = 1"
using carrier_matD[OF dimBmA] by (auto intro: carrier_vecI)
have dimov: "outer_prod v v ∈ carrier_mat n n" using dimv by auto
then have "partial_density_operator (outer_prod v v)"
using dimv nv pure_state_self_outer_prod_is_partial_density_operator by auto
then have leq: "trace(A * (outer_prod v v)) ≤ trace(B * (outer_prod v v))" using asm dimov by auto
have "trace((B - A) * (outer_prod v v)) = trace(B * (outer_prod v v)) - trace(A * (outer_prod v v))" using A B dimov
apply (subst minus_mult_distrib_mat, auto)
apply (subst trace_minus_linear, auto)
done
then have "trace((B - A) * (outer_prod v v)) ≥ 0" using leq by auto
then have "inner_prod v ((B - A) *⇩v v) ≥ 0" using trace_outer_prod_right[OF dimBmA dimv dimv] by auto
}
then show "positive (B - A)" using positive_iff_normalized_vec[of "B - A"] dimBmA A by simp
qed
then show "A ≤⇩L B" using lowner_le_def A B by auto
}
qed
lemma lowner_le_traceI:
assumes "A ∈ carrier_mat n n"
and "B ∈ carrier_mat n n"
and "⋀ρ. ρ ∈ carrier_mat n n ⟹ partial_density_operator ρ ⟹ trace (A * ρ) ≤ trace (B * ρ)"
shows "A ≤⇩L B"
using lowner_le_trace assms by auto
lemma trace_pdo_eq_imp_eq:
assumes A: "A ∈ carrier_mat n n"
and B: "B ∈ carrier_mat n n"
and teq: "⋀ρ. ρ ∈ carrier_mat n n ⟹ partial_density_operator ρ ⟹ trace (A * ρ) = trace (B * ρ)"
shows "A = B"
proof -
from teq have "A ≤⇩L B" using lowner_le_trace[OF A B] teq by auto
moreover from teq have "B ≤⇩L A" using lowner_le_trace[OF B A] teq by auto
ultimately show "A = B" using lowner_le_antisym A B by auto
qed
lemma lowner_le_traceD:
assumes "A ∈ carrier_mat n n" "B ∈ carrier_mat n n" "ρ ∈ carrier_mat n n"
and "A ≤⇩L B"
and "partial_density_operator ρ"
shows "trace (A * ρ) ≤ trace (B * ρ)"
using lowner_le_trace assms by blast
lemma sum_only_one_neq_0:
assumes "finite A" and "j ∈ A" and "⋀i. i ∈ A ⟹ i ≠ j ⟹ g i = 0"
shows "sum g A = g j"
proof -
have "{j} ⊆ A" using assms by auto
moreover have "∀i∈A - {j}. g i = 0" using assms by simp
ultimately have "sum g A = sum g {j}" using assms
by (auto simp add: comm_monoid_add_class.sum.mono_neutral_right[of A "{j}" g])
moreover have "sum g {j} = g j" by simp
ultimately show ?thesis by auto
qed
end
File ‹mat_alg.ML›
fun string_of_terms ctxt ts =
ts |> map (Syntax.pretty_term ctxt)
|> Pretty.commas |> Pretty.block |> Pretty.string_of
fun trace_t ctxt s t =
tracing (s ^ " " ^ (Syntax.string_of_term ctxt t))
fun trace_fullthm ctxt s th =
tracing (s ^ " [" ^ (Thm.hyps_of th |> string_of_terms ctxt) ^
"] ==> " ^ (Thm.prop_of th |> Syntax.string_of_term ctxt))
val natT = HOLogic.natT
fun is_times t =
case t of
Const (@{const_name times}, _) $ _ $ _ => true
| _ => false
fun is_plus t =
case t of
Const (@{const_name plus}, _) $ _ $ _ => true
| _ => false
fun is_minus t =
case t of
Const (@{const_name minus}, _) $ _ $ _ => true
| _ => false
fun is_uminus t =
case t of
Const (@{const_name uminus}, _) $ _ => true
| _ => false
fun dest_binop t =
case t of
_ $ a $ b => (a, b)
| _ => raise Fail "dest_binop"
fun dest_arg t =
case t of
_ $ x => x
| _ => raise Fail "dest_arg"
fun dest_arg1 t =
case t of
_ $ arg1 $ _ => arg1
| _ => raise Fail "dest_arg1"
fun is_mat_type t =
is_Type (fastype_of t) andalso
(fastype_of t |> dest_Type |> fst) = "Matrix.mat"
fun is_smult_mat t =
case t of
Const (@{const_name smult_mat}, _) $ _ $ _ => true
| _ => false
fun is_adjoint t =
case t of
Const (@{const_name mat_adjoint}, _) $ _ => true
| _ => false
fun is_id_mat t =
case t of
Const (@{const_name one_mat}, _) $ _ => true
| _ => false
fun is_zero_mat t =
case t of
Const (@{const_name zero_mat}, _) $ _ $ _ => true
| _ => false
fun strip_times t =
if is_times t then
strip_times (dest_arg1 t) @ [dest_arg t]
else
[t]
fun carrier_mat n t =
let
val T = fastype_of t
val Tset = HOLogic.mk_setT T
in
Const (@{const_name carrier_mat}, natT --> natT --> Tset) $ n $ n
end
fun mk_mem_carrier n t =
HOLogic.mk_mem (t, carrier_mat n t)
fun assume_carrier ctxt n t =
Thm.assume (Thm.cterm_of ctxt (HOLogic.mk_Trueprop (mk_mem_carrier n t)))
fun prod_in_carrier ctxt n t =
if is_times t then
let
val (a, b) = dest_binop t
val th1 = prod_in_carrier ctxt n a
val th2 = prod_in_carrier ctxt n b
in
[th1, th2] MRS @{thm mult_carrier_mat}
end
else if is_plus t then
let
val (a, b) = dest_binop t
val th1 = prod_in_carrier ctxt n a
val th2 = prod_in_carrier ctxt n b
in
[th1, th2] MRS @{thm add_carrier_mat'}
end
else if is_uminus t then
let
val a = dest_arg t
val th = prod_in_carrier ctxt n a
in
th RS @{thm uminus_carrier_mat}
end
else if is_minus t then
let
val (a, b) = dest_binop t
val th1 = prod_in_carrier ctxt n a
val th2 = prod_in_carrier ctxt n b
in
[th1, th2] MRS @{thm minus_carrier_mat'}
end
else if is_adjoint t then
let
val a = dest_arg t
val th = prod_in_carrier ctxt n a
in
th RS @{thm adjoint_dim}
end
else if is_smult_mat t then
let
val a = dest_arg t
val th = prod_in_carrier ctxt n a
in
th RS @{thm smult_carrier_mat}
end
else
assume_carrier ctxt n t
fun obj_sym th =
th RS @{thm HOL.sym}
fun to_meta_eq th =
th RS @{thm HOL.eq_reflection}
fun to_obj_eq th =
th RS @{thm HOL.meta_eq_to_obj_eq}
fun rewr_cv ctxt n th ct =
let
val th = to_meta_eq th
val pat = th |> Thm.concl_of |> dest_arg1 |> Thm.cterm_of ctxt
val inst = Thm.match (pat, ct)
val th = Thm.instantiate inst th
val prems = map (fn prem => prod_in_carrier ctxt n (prem |> dest_arg |> dest_arg1))
(Thm.prems_of th)
in
prems MRS th
end
handle THM _ => let val _ = trace_fullthm ctxt "here" th in raise Fail "THM" end
| Pattern.MATCH => let val _ = trace_fullthm ctxt "here" th in raise Fail "MATCH" end
fun assoc_times_norm ctxt n ct =
let
val t = Thm.term_of ct
val (a, b) = dest_binop t
in
if is_smult_mat a then
Conv.every_conv [
rewr_cv ctxt n @{thm mult_smult_assoc_mat},
Conv.arg_conv (assoc_times_norm ctxt n)] ct
else if is_smult_mat b then
Conv.every_conv [
rewr_cv ctxt n @{thm mult_smult_distrib},
Conv.arg_conv (assoc_times_norm ctxt n)] ct
else if is_times b then
Conv.every_conv [
rewr_cv ctxt n (obj_sym @{thm assoc_mult_mat}),
Conv.arg1_conv (assoc_times_norm ctxt n)] ct
else if is_id_mat a then
rewr_cv ctxt n @{thm left_mult_one_mat} ct
else if is_id_mat b then
rewr_cv ctxt n @{thm right_mult_one_mat} ct
else
Conv.all_conv ct
end
fun assoc_plus_one_norm ctxt n ct =
let
val t = Thm.term_of ct
val (a, b) = dest_binop t
in
if not (is_mat_type t) then
Conv.all_conv ct
else if is_plus a then
if Term_Ord.term_ord (dest_arg a, b) = GREATER then
Conv.every_conv [
rewr_cv ctxt n @{thm swap_plus_mat},
Conv.arg1_conv (assoc_plus_one_norm ctxt n)] ct
else
Conv.all_conv ct
else
if Term_Ord.term_ord (a, b) = GREATER then
rewr_cv ctxt n @{thm comm_add_mat} ct
else
Conv.all_conv ct
end
fun assoc_plus_norm ctxt n ct =
let
val t = Thm.term_of ct
val (a, b) = dest_binop t
in
if not (is_mat_type t) then
Conv.all_conv ct
else if is_plus b then
Conv.every_conv [
rewr_cv ctxt n (obj_sym @{thm assoc_add_mat}),
Conv.arg1_conv (assoc_plus_norm ctxt n),
assoc_plus_one_norm ctxt n] ct
else if is_zero_mat a then
rewr_cv ctxt n @{thm left_add_zero_mat} ct
else if is_zero_mat b then
rewr_cv ctxt n @{thm right_add_zero_mat} ct
else
assoc_plus_one_norm ctxt n ct
end
fun smult_plus_norm ctxt n ct =
let
val t = Thm.term_of ct
in
if is_plus (dest_arg t) then
Conv.every_conv [
rewr_cv ctxt n @{thm add_smult_distrib_left_mat},
Conv.arg1_conv (smult_plus_norm ctxt n)] ct
else
Conv.all_conv ct
end
fun norm_mult_poly_monomial ctxt n ct =
let
val t = Thm.term_of ct
in
if is_plus (dest_arg1 t) then
Conv.every_conv [
rewr_cv ctxt n @{thm add_mult_distrib_mat},
Conv.arg1_conv (norm_mult_poly_monomial ctxt n),
Conv.arg_conv (assoc_times_norm ctxt n),
assoc_plus_norm ctxt n] ct
else
assoc_times_norm ctxt n ct
end
fun norm_mult_polynomials ctxt n ct =
let
val t = Thm.term_of ct
in
if is_plus (dest_arg t) then
Conv.every_conv [
rewr_cv ctxt n @{thm mult_add_distrib_mat},
Conv.arg1_conv (norm_mult_polynomials ctxt n),
Conv.arg_conv (norm_mult_poly_monomial ctxt n),
assoc_plus_norm ctxt n] ct
else
norm_mult_poly_monomial ctxt n ct
end
fun is_trace t =
case t of
Const (@{const_name trace}, _) $ _ => true
| _ => false
fun norm_trace_times ctxt n ct =
let
val tt = Thm.term_of ct
val t = dest_arg tt
val ts = strip_times t
val (rest, last) = split_last ts
in
if exists (fn t' => Term_Ord.term_ord (last, t') = LESS) rest then
Conv.every_conv [
rewr_cv ctxt n @{thm trace_comm},
Conv.arg_conv (assoc_times_norm ctxt n),
norm_trace_times ctxt n] ct
else
Conv.all_conv ct
end
fun norm_trace_plus ctxt n ct =
let
val tt = Thm.term_of ct
val t = dest_arg tt
in
if is_plus t then
Conv.every_conv [
rewr_cv ctxt n @{thm trace_add_linear},
Conv.arg1_conv (norm_trace_plus ctxt n),
Conv.arg_conv (norm_trace_times ctxt n)] ct
else
norm_trace_times ctxt n ct
end
fun assoc_norm ctxt n ct =
let
val t = Thm.term_of ct
in
if is_times t then
Conv.every_conv [
Conv.binop_conv (assoc_norm ctxt n),
norm_mult_polynomials ctxt n] ct
else if is_plus t then
Conv.every_conv [
Conv.binop_conv (assoc_norm ctxt n),
assoc_plus_norm ctxt n] ct
else if is_smult_mat t then
Conv.every_conv [
Conv.arg_conv (assoc_norm ctxt n),
smult_plus_norm ctxt n] ct
else if is_minus t then
Conv.every_conv [
rewr_cv ctxt n @{thm minus_add_uminus_mat},
assoc_norm ctxt n] ct
else if is_uminus t then
Conv.every_conv [
rewr_cv ctxt n @{thm uminus_mat},
assoc_norm ctxt n] ct
else if is_adjoint t then
if is_times (dest_arg t) then
Conv.every_conv [
rewr_cv ctxt n @{thm adjoint_mult},
assoc_norm ctxt n] ct
else if is_adjoint (dest_arg t) then
Conv.every_conv [
Conv.rewr_conv (to_meta_eq @{thm adjoint_adjoint}),
assoc_norm ctxt n] ct
else
Conv.all_conv ct
else if is_trace t then
Conv.every_conv [
Conv.arg_conv (assoc_norm ctxt n),
norm_trace_plus ctxt n] ct
else
Conv.all_conv ct
end
fun prove_by_assoc_norm ctxt n t =
let
val _ = trace_t ctxt "To show equation:" t
val (a, b) = dest_binop t
val norm1 = assoc_norm ctxt n (Thm.cterm_of ctxt a)
val norm2 = assoc_norm ctxt n (Thm.cterm_of ctxt b)
in
if Thm.rhs_of norm1 aconvc Thm.rhs_of norm2 then
let
val res = Thm.transitive norm1 (Thm.symmetric norm2)
in
res |> to_obj_eq
end
else
let
val _ = trace_t ctxt "Left side is:" (Thm.term_of (Thm.rhs_of norm1))
val _ = trace_t ctxt "Right side is:" (Thm.term_of (Thm.rhs_of norm2))
in
raise Fail "Normalization are not equal."
end
end
fun prove_by_assoc_norm_tac n ctxt state =
let
val n = Syntax.read_term ctxt n
val subgoals = Thm.prems_of state
in
if null subgoals then Seq.empty else
let
val subgoal = state |> Drule.cprems_of |> hd
val (cprems, cconcl) = (Drule.strip_imp_prems subgoal, Drule.strip_imp_concl subgoal)
val concl = HOLogic.dest_Trueprop (Thm.term_of cconcl)
val subgoal_th = fold Thm.implies_intr (rev cprems) (prove_by_assoc_norm ctxt n concl)
val chyps = Thm.chyps_of subgoal_th
val res = Thm.implies_elim state subgoal_th
in
Seq.single (fold Thm.implies_intr chyps res)
end
end
val mat_assoc_method : (Proof.context -> Method.method) context_parser =
Scan.lift Parse.term >> (fn n => fn ctxt => (SIMPLE_METHOD (prove_by_assoc_norm_tac n ctxt)))
Theory Matrix_Limit
section ‹Matrix limits›
theory Matrix_Limit
imports Complex_Matrix
begin
subsection ‹Definition of limit of matrices›
definition limit_mat :: "(nat ⇒ complex mat) ⇒ complex mat ⇒ nat ⇒ bool" where
"limit_mat X A m ⟷ (∀ n. X n ∈ carrier_mat m m ∧ A ∈ carrier_mat m m ∧
(∀ i < m. ∀ j < m. (λ n. (X n) $$ (i, j)) ⇢ (A $$ (i, j))))"
lemma limit_mat_unique:
assumes limA: "limit_mat X A m" and limB: "limit_mat X B m"
shows "A = B"
proof -
have dim: "A ∈ carrier_mat m m" "B ∈ carrier_mat m m" using limA limB limit_mat_def by auto
{
fix i j assume i: "i < m" and j: "j < m"
have "(λ n. (X n) $$ (i, j)) ⇢ (A $$ (i, j))" using limit_mat_def limA i j by auto
moreover have "(λ n. (X n) $$ (i, j)) ⇢ (B $$ (i, j))" using limit_mat_def limB i j by auto
ultimately have "(A $$ (i, j)) = (B $$ (i, j))" using LIMSEQ_unique by auto
}
then show "A = B" using mat_eq_iff dim by auto
qed
lemma limit_mat_const:
fixes A :: "complex mat"
assumes "A ∈ carrier_mat m m"
shows "limit_mat (λk. A) A m"
unfolding limit_mat_def using assms by auto
lemma limit_mat_scale:
fixes X :: "nat ⇒ complex mat" and A :: "complex mat"
assumes limX: "limit_mat X A m"
shows "limit_mat (λn. c ⋅⇩m X n) (c ⋅⇩m A) m"
proof -
have dimA: "A ∈ carrier_mat m m" using limX limit_mat_def by auto
have dimX: "⋀n. X n ∈ carrier_mat m m" using limX unfolding limit_mat_def by auto
have "⋀i j. i < m ⟹ j < m ⟹ (λn. (c ⋅⇩m X n) $$ (i, j)) ⇢ (c ⋅⇩m A) $$ (i, j)"
proof -
fix i j assume i: "i < m" and j: "j < m"
have "(λn. (X n) $$ (i, j)) ⇢ A$$(i, j)" using limX limit_mat_def i j by auto
moreover have "(λn. c) ⇢ c" by auto
ultimately have "(λn. c * (X n) $$ (i, j)) ⇢ c * A$$(i, j)"
using tendsto_mult[of "λn. c" c] limX limit_mat_def by auto
moreover have "(c ⋅⇩m X n) $$ (i, j) = c * (X n) $$ (i, j)" for n
using index_smult_mat(1)[of i "X n" j c] i j dimX[of n] by auto
moreover have "(c ⋅⇩m A) $$ (i, j) = c * A $$ (i, j)"
using index_smult_mat(1)[of i "A" j c] i j dimA by auto
ultimately show "(λn. (c ⋅⇩m X n) $$ (i, j)) ⇢ (c ⋅⇩m A) $$ (i, j)" by auto
qed
then show ?thesis unfolding limit_mat_def using dimA dimX by auto
qed
lemma limit_mat_add:
fixes X :: "nat ⇒ complex mat" and Y :: "nat ⇒ complex mat" and A :: "complex mat"
and m :: nat and B :: "complex mat"
assumes limX: "limit_mat X A m" and limY: "limit_mat Y B m"
shows "limit_mat (λk. X k + Y k) (A + B) m"
proof -
have dimA: "A ∈ carrier_mat m m" using limX limit_mat_def by auto
have dimB: "B ∈ carrier_mat m m" using limY limit_mat_def by auto
have dimX: "⋀n. X n ∈ carrier_mat m m" using limX unfolding limit_mat_def by auto
have dimY: "⋀n. Y n ∈ carrier_mat m m" using limY unfolding limit_mat_def by auto
then have dimXAB: "∀n. X n + Y n ∈ carrier_mat m m ∧ A + B ∈ carrier_mat m m" using dimA dimB dimX dimY
by (simp)
have "(⋀i j. i < m ⟹ j < m ⟹ (λn. (X n + Y n) $$ (i, j)) ⇢ (A + B) $$ (i, j))"
proof -
fix i j assume i: "i < m" and j: "j < m"
have "(λn. (X n) $$ (i, j)) ⇢ A$$(i, j)" using limX limit_mat_def i j by auto
moreover have "(λn. (Y n) $$ (i, j)) ⇢ B$$(i, j)" using limY limit_mat_def i j by auto
ultimately have "(λn. (X n)$$(i, j) + (Y n) $$ (i, j)) ⇢ (A$$(i, j) + B$$(i, j))"
using tendsto_add[of "λn. (X n) $$ (i, j)" "A $$ (i, j)"] by auto
moreover have "(X n + Y n) $$ (i, j) = (X n)$$(i, j) + (Y n) $$ (i, j)" for n
using i j dimX dimY index_add_mat(1)[of i "Y n" j "X n"] by fastforce
moreover have "(A + B) $$ (i, j) = A$$(i, j) + B$$(i, j)"
using i j dimA dimB by fastforce
ultimately show "(λn. (X n + Y n) $$ (i, j)) ⇢ (A + B) $$ (i, j)" by auto
qed
then show ?thesis
unfolding limit_mat_def using dimXAB by auto
qed
lemma limit_mat_minus:
fixes X :: "nat ⇒ complex mat" and Y :: "nat ⇒ complex mat" and A :: "complex mat"
and m :: nat and B :: "complex mat"
assumes limX: "limit_mat X A m" and limY: "limit_mat Y B m"
shows "limit_mat (λk. X k - Y k) (A - B) m"
proof -
have dimA: "A ∈ carrier_mat m m" using limX limit_mat_def by auto
have dimB: "B ∈ carrier_mat m m" using limY limit_mat_def by auto
have dimX: "⋀n. X n ∈ carrier_mat m m" using limX unfolding limit_mat_def by auto
have dimY: "⋀n. Y n ∈ carrier_mat m m" using limY unfolding limit_mat_def by auto
have "-1 ⋅⇩m Y n = - Y n" for n using dimY by auto
moreover have "-1 ⋅⇩m B = - B" using dimB by auto
ultimately have "limit_mat (λn. - Y n) (- B) m" using limit_mat_scale[OF limY, of "-1"] by auto
then have "limit_mat (λn. X n + (- Y n)) (A + (- B)) m" using limit_mat_add limX by auto
moreover have "X n + (- Y n) = X n - Y n" for n using dimX dimY by auto
moreover have "A + (- B) = A - B" by auto
ultimately show ?thesis by auto
qed
lemma limit_mat_mult:
fixes X :: "nat ⇒ complex mat" and Y :: "nat ⇒ complex mat" and A :: "complex mat"
and m :: nat and B :: "complex mat"
assumes limX: "limit_mat X A m" and limY: "limit_mat Y B m"
shows "limit_mat (λk. X k * Y k) (A * B) m"
proof -
have dimA: "A ∈ carrier_mat m m" using limX limit_mat_def by auto
have dimB: "B ∈ carrier_mat m m" using limY limit_mat_def by auto
have dimX: "⋀n. X n ∈ carrier_mat m m" using limX unfolding limit_mat_def by auto
have dimY: "⋀n. Y n ∈ carrier_mat m m" using limY unfolding limit_mat_def by auto
then have dimXAB: "∀n. X n * Y n ∈ carrier_mat m m ∧ A * B ∈ carrier_mat m m" using dimA dimB dimX dimY
by fastforce
have "(⋀i j. i < m ⟹ j < m ⟹ (λn. (X n * Y n) $$ (i, j)) ⇢ (A * B) $$ (i, j))"
proof -
fix i j assume i: "i < m" and j: "j < m"
have eqn: "(X n * Y n) $$ (i, j) = (∑k=0..<m. (X n)$$(i, k) * (Y n)$$(k, j))" for n
using i j dimX[of n] dimY[of n] by (auto simp add: scalar_prod_def)
have eq: "(A * B) $$ (i, j) = (∑k=0..<m. A$$(i,k) * B$$(k,j))"
using i j dimB dimA by (auto simp add: scalar_prod_def)
have "(λn. (X n) $$ (i, k)) ⇢ A$$(i, k)" if "k < m" for k using limX limit_mat_def that i by auto
moreover have "(λn. (Y n) $$ (k, j)) ⇢ B$$(k, j)" if "k < m" for k using limY limit_mat_def that j by auto
ultimately have "(λn. (X n)$$(i, k) * (Y n)$$(k,j)) ⇢ A$$(i, k) * B$$(k, j)" if "k < m" for k
using tendsto_mult[of "λn. (X n) $$ (i, k)" "A$$(i, k)" _ "λn. (Y n)$$(k, j)" "B$$(k, j)"] that by auto
then have "(λn. (∑k=0..<m. (X n)$$(i,k) * (Y n)$$(k,j))) ⇢ (∑k=0..<m. A$$(i,k) * B$$(k,j))"
using tendsto_sum[of "{0..<m}" "λk n. (X n)$$(i,k) * (Y n)$$(k,j)" "λk. A$$(i, k) * B$$(k, j)"] by auto
then show "(λn. (X n * Y n) $$ (i, j)) ⇢ (A * B) $$ (i, j)" using eqn eq by auto
qed
then show ?thesis
unfolding limit_mat_def using dimXAB by fastforce
qed
text ‹Adding matrix A to the sequence X›
definition mat_add_seq :: "complex mat ⇒ (nat ⇒ complex mat) ⇒ nat ⇒ complex mat" where
"mat_add_seq A X = (λn. A + X n)"
lemma mat_add_limit:
fixes X :: "nat ⇒ complex mat" and A :: "complex mat" and m :: nat and B :: "complex mat"
assumes dimB: "B ∈ carrier_mat m m" and limX: "limit_mat X A m"
shows "limit_mat (mat_add_seq B X) (B + A) m"
unfolding mat_add_seq_def using limit_mat_add limit_mat_const[OF dimB] limX by auto
lemma mat_minus_limit:
fixes X :: "nat ⇒ complex mat" and A :: "complex mat" and m :: nat and B :: "complex mat"
assumes dimB: "B ∈ carrier_mat m m" and limX: "limit_mat X A m"
shows "limit_mat (λn. B - X n) (B - A) m"
using limit_mat_minus limit_mat_const[OF dimB] limX by auto
text ‹Multiply matrix A by the sequence X›
definition mat_mult_seq :: "complex mat ⇒ (nat ⇒ complex mat) ⇒ nat ⇒ complex mat" where
"mat_mult_seq A X = (λn. A * X n)"
lemma mat_mult_limit:
fixes X :: "nat ⇒ complex mat" and A B :: "complex mat" and m :: nat
assumes dimB: "B ∈ carrier_mat m m" and limX: "limit_mat X A m"
shows "limit_mat (mat_mult_seq B X) (B * A) m"
unfolding mat_mult_seq_def using limit_mat_mult limit_mat_const[OF dimB] limX by auto
lemma mult_mat_limit:
fixes X :: "nat ⇒ complex mat" and A B :: "complex mat" and m :: nat
assumes dimB: "B ∈ carrier_mat m m" and limX: "limit_mat X A m"
shows "limit_mat (λk. X k * B) (A * B) m"
unfolding mat_mult_seq_def using limit_mat_mult limit_mat_const[OF dimB] limX by auto
lemma quadratic_form_mat:
fixes A :: "complex mat" and v :: "complex vec" and m :: nat
assumes dimv: "dim_vec v = m" and dimA: "A ∈ carrier_mat m m"
shows "inner_prod v (A *⇩v v) = (∑i=0..<m. (∑j=0..<m. conjugate (v$i) * A$$(i, j) * v$j))"
proof -
have "inner_prod v (A *⇩v v) = (∑i=0..<m. (∑j=0..<m.
conjugate (v$i) * A$$(i, j) * v$j))"
unfolding scalar_prod_def using dimv dimA
apply (simp add: scalar_prod_def sum_distrib_right)
apply (rule sum.cong, auto, rule sum.cong, auto)
done
then show ?thesis by auto
qed
lemma sum_subtractff:
fixes h g :: "nat ⇒ nat ⇒'a::ab_group_add"
shows "(∑x∈A. ∑y∈B. h x y - g x y) = (∑x∈A. ∑y∈B. h x y) - (∑x∈A. ∑y∈B. g x y)"
proof -
have "∀ x ∈ A. (∑y∈B. h x y - g x y) = (∑y∈B. h x y) - (∑y∈B. g x y)"
proof -
{
fix x assume x: "x ∈ A"
have "(∑y∈B. h x y - g x y) = (∑y∈B. h x y) - (∑y∈B. g x y)"
using sum_subtractf by auto
}
then show ?thesis using sum_subtractf by blast
qed
then have "(∑x∈A.∑y∈B. h x y - g x y) = (∑x∈A. ((∑y∈B. h x y) - (∑y∈B. g x y)))" by auto
also have "… = (∑x∈A. ∑y∈B. h x y) - (∑x∈A. ∑y∈B. g x y)"
by (simp add: sum_subtractf)
finally have " (∑x∈A. ∑y∈B. h x y - g x y) = (∑x∈A. sum (h x) B) - (∑x∈A. sum (g x) B)" by auto
then show ?thesis by auto
qed
lemma sum_abs_complex:
fixes h :: "nat ⇒ nat ⇒ complex"
shows "cmod (∑x∈A.∑y∈B. h x y) ≤ (∑x∈A. ∑y∈B. cmod(h x y))"
proof -
have B: "∀ x ∈ A. cmod( ∑y∈B .h x y) ≤ (∑y∈B. cmod(h x y))" using sum_abs norm_sum by blast
have "cmod (∑x∈A.∑y∈B. h x y) ≤ (∑x∈A. cmod( ∑y∈B .h x y))" using sum_abs norm_sum by blast
also have "… ≤ (∑x∈A. ∑y∈B. cmod(h x y))" using sum_abs norm_sum B
by (simp add: sum_mono)
finally have "cmod (∑x∈A. ∑y∈B. h x y) ≤ (∑x∈A. ∑y∈B. cmod (h x y))" by auto
then show ?thesis by auto
qed
lemma hermitian_mat_lim_is_hermitian:
fixes X :: "nat ⇒ complex mat" and A :: "complex mat" and m :: nat
assumes limX: "limit_mat X A m" and herX: "∀ n. hermitian (X n)"
shows "hermitian A"
proof -
have dimX: "∀n. X n ∈ carrier_mat m m" using limX unfolding limit_mat_def by auto
have dimA : "A ∈ carrier_mat m m" using limX unfolding limit_mat_def by auto
from herX have herXn: "∀ n. adjoint (X n) = (X n)" unfolding hermitian_def by auto
from limX have limXn: "∀i<m. ∀j<m. (λn. X n $$ (i, j)) ⇢ A $$ (i, j)" unfolding limit_mat_def by auto
have "∀i<m. ∀j<m.(adjoint A)$$ (i, j) = A$$ (i, j)"
proof -
{
fix i j assume i: "i < m" and j: "j < m"
have aij: "(adjoint A)$$ (i, j) = conjugate (A $$ (j,i))" using adjoint_eval i j dimA by blast
have ij: "(λn. X n $$ (i, j)) ⇢ A $$ (i, j)" using limXn i j by auto
have ji: "(λn. X n $$ (j, i)) ⇢ A $$ (j, i)" using limXn i j by auto
then have "∀r>0. ∃no. ∀n≥no. dist (conjugate (X n $$ (j, i))) (conjugate (A $$ (j, i))) < r"
proof -
{
fix r :: real assume r : "r > 0"
have "∃no. ∀n≥no. cmod (X n $$ (j, i) - A $$ (j, i)) < r" using ji r unfolding LIMSEQ_def dist_norm by auto
then obtain no where Xji: "∀n≥no. cmod (X n $$ (j, i) - A $$ (j, i)) < r" by auto
then have "∀n≥no. cmod (conjugate (X n $$ (j, i) - A $$ (j, i))) < r"
using complex_mod_cnj conjugate_complex_def by presburger
then have "∀n≥no. dist (conjugate (X n $$ (j, i))) (conjugate (A $$ (j, i))) < r" unfolding dist_norm by auto
then have "∃no. ∀n≥no. dist (conjugate (X n $$ (j, i))) (conjugate (A $$ (j, i))) < r" by auto
}
then show ?thesis by auto
qed
then have conjX: "(λn. conjugate (X n $$ (j, i))) ⇢ conjugate (A $$ (j, i))" unfolding LIMSEQ_def by auto
from herXn have "∀ n. conjugate (X n $$ (j,i)) = X n$$ (i, j)" using adjoint_eval i j dimX
by (metis adjoint_dim_col carrier_matD(1))
then have "(λn. X n $$ (i, j)) ⇢ conjugate (A $$ (j, i))" using conjX by auto
then have "conjugate (A $$ (j,i)) = A$$ (i, j)" using ij by (simp add: LIMSEQ_unique)
then have "(adjoint A)$$ (i, j) = A$$ (i, j)" using adjoint_eval i j by (simp add:aij)
}
then show ?thesis by auto
qed
then have "hermitian A" using hermitian_def dimA
by (metis adjoint_dim carrier_matD(1) carrier_matD(2) eq_matI)
then show ?thesis by auto
qed
lemma quantifier_change_order_once:
fixes P :: "nat ⇒ nat ⇒ bool" and m :: nat
shows "∀j<m. ∃no. ∀n≥no. P n j ⟹ ∃no. ∀j<m. ∀n≥no. P n j"
proof (induct m)
case 0
then show ?case by auto
next
case (Suc m)
then show ?case
proof -
have mm: "∃no. ∀j<m. ∀n≥no. P n j" using Suc by auto
then obtain M where MM: "∀j<m. ∀n≥M. P n j" by auto
have sucm: "∃no. ∀n≥no. P n m" using Suc(2) by auto
then obtain N where NN: "∀n≥N. P n m" by auto
let ?N = "max M N"
from MM NN have "∀j<Suc m. ∀n≥?N. P n j"
by (metis less_antisym max.boundedE)
then have "∃no. ∀j<Suc m. ∀n≥no. P n j" by blast
then show ?thesis by auto
qed
qed
lemma quantifier_change_order_twice:
fixes P :: "nat ⇒ nat ⇒ nat ⇒ bool" and m n :: nat
shows "∀i<m. ∀j<n. ∃ no. ∀n≥no. P n i j ⟹ ∃no. ∀i<m. ∀j<n. ∀n≥no. P n i j"
proof -
assume fact: "∀i<m. ∀j<n. ∃ no. ∀n≥no. P n i j"
have one: "∀i<m. ∃no.∀j<n. ∀n≥no. P n i j"
using fact quantifier_change_order_once by auto
have two: "∀i<m. ∃no.∀j<n. ∀n≥no. P n i j ⟹ ∃no. ∀i<m. ∀j<n. ∀n≥no. P n i j"
proof (induct m)
case 0
then show ?case by auto
next
case (Suc m)
then show ?case
proof -
obtain M where MM: "∀i<m. ∀j<n. ∀n≥M. P n i j" using Suc by auto
obtain N where NN: "∀j<n. ∀n≥N. P n m j" using Suc(2) by blast
let ?N = "max M N"
from MM NN have "∀i<Suc m. ∀j<n. ∀n≥?N. P n i j"
by (metis less_antisym max.boundedE)
then have "∃no. ∀i<Suc m. ∀j<n. ∀n≥no. P n i j" by blast
then show ?thesis by auto
qed
qed
with fact show ?thesis using one by auto
qed
lemma pos_mat_lim_is_pos:
fixes X :: "nat ⇒ complex mat" and A :: "complex mat" and m :: nat
assumes limX: "limit_mat X A m" and posX: "∀n. positive (X n)"
shows "positive A"
proof (rule ccontr)
have dimX : "∀n. X n ∈ carrier_mat m m" using limX unfolding limit_mat_def by auto
have dimA : "A ∈ carrier_mat m m" using limX unfolding limit_mat_def by auto
have herX : "∀ n. hermitian (X n)" using posX positive_is_hermitian by auto
then have herA : "hermitian A" using hermitian_mat_lim_is_hermitian limX by auto
then have herprod: "∀ v. dim_vec v = dim_col A ⟶ inner_prod v (A *⇩v v) ∈ Reals"
using hermitian_inner_prod_real dimA by auto
assume npA: " ¬ positive A"
from npA have "¬ (A ∈ carrier_mat (dim_col A) (dim_col A)) ∨ ¬ (∀v. dim_vec v = dim_col A ⟶ 0 ≤ inner_prod v (A *⇩v v))"
unfolding positive_def by blast
then have evA: "∃ v. dim_vec v = dim_col A ∧ ¬ inner_prod v (A *⇩v v) ≥ 0" using dimA by blast
then have "∃ v. dim_vec v = dim_col A ∧ inner_prod v (A *⇩v v) < 0"
proof -
obtain v where vA: "dim_vec v = dim_col A ∧ ¬ inner_prod v (A *⇩v v) ≥ 0" using evA by auto
from vA herprod have "¬ 0 ≤ inner_prod v (A *⇩v v) ∧ inner_prod v (A *⇩v v) ∈ Reals" by auto
then have "inner_prod v (A *⇩v v) < 0"
using complex_is_Real_iff by auto
then have "∃ v. dim_vec v = dim_col A ∧ inner_prod v (A *⇩v v) < 0" using vA by auto
then show ?thesis by auto
qed
then obtain v where neg: "dim_vec v = dim_col A ∧ inner_prod v (A *⇩v v) < 0" by auto
have nzero: "v ≠ 0⇩v m"
proof (rule ccontr)
assume nega: " ¬ v ≠ 0⇩v m"
have zero: "v = 0⇩v m" using nega by auto
have "(A *⇩v v) = 0⇩v m" unfolding mult_mat_vec_def using zero
using dimA by auto
then have zerov: "inner_prod v (A *⇩v v) = 0" by (simp add: zero)
from neg zerov have "¬ v ≠ 0⇩v m ⟹ False" using dimA by auto
with nega show False by auto
qed
have invgeq: "inner_prod v v > 0"
proof -
have "inner_prod v v = vec_norm v * vec_norm v" unfolding vec_norm_def
by (metis carrier_matD(2) carrier_vec_dim_vec dimA mult_cancel_left1 neg normalized_cscalar_prod normalized_vec_norm nzero vec_norm_def)
moreover have "vec_norm v > 0" using nzero vec_norm_ge_0 neg dimA
by (metis carrier_matD(2) carrier_vec_dim_vec)
ultimately have "inner_prod v v > 0" by auto
then show ?thesis by auto
qed
have invv: "inner_prod v v = (∑i = 0..<m. cmod (conjugate (v $ i) * (v $ i)))"
proof -
{
have "∀ i < m. conjugate (v $ i) * (v $ i) ≥ 0" using conjugate_square_smaller_0 by simp
then have vi: "∀ i < m. conjugate (v $ i) * (v $ i) = cmod (conjugate (v $ i) * (v $ i))" using cmod_eq_Re
by (simp add: complex.expand)
have "inner_prod v v= (∑i = 0..<m. ((v $ i) * conjugate (v $ i)))"
unfolding scalar_prod_def conjugate_vec_def using neg dimA by auto
also have "… = (∑i = 0..<m. (conjugate (v $ i) * (v $ i)))"
by (meson mult.commute)
also have "… = (∑i = 0..<m. cmod (conjugate (v $ i) * (v $ i)))" using vi by auto
finally have "inner_prod v v = (∑i = 0..<m. cmod (conjugate (v $ i) * (v $ i)))" by auto
}
then show ?thesis by auto
qed
let ?r = "inner_prod v (A *⇩v v)" have rl: "?r < 0" using neg by auto
have vAv: "inner_prod v (A *⇩v v) = (∑i=0..<m. (∑j=0..<m.
conjugate (v$i) * A$$(i, j) * v$j))" using quadratic_form_mat dimA neg by auto
from limX have limij: "∀i<m. ∀j<m. (λn. X n $$ (i, j)) ⇢ A $$ (i, j)" unfolding limit_mat_def by auto
then have limXv: "(λ n. inner_prod v ((X n) *⇩v v)) ⇢ inner_prod v (A *⇩v v)"
proof -
have XAless: "cmod (inner_prod v (X n *⇩v v) - inner_prod v (A *⇩v v)) ≤
(∑i = 0..<m. ∑j = 0..<m. cmod (conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod (v $ j))" for n
proof -
have "∀ i < m. ∀ j < m. conjugate (v$i) * X n $$(i, j) * v$j - conjugate (v$i) * A$$(i, j) * v$j =
conjugate (v$i) * (X n $$(i, j)-A$$(i, j)) * v$j"
by (simp add: mult.commute right_diff_distrib)
then have ele: "∀ i < m.(∑j=0..<m.(conjugate (v$i) * X n $$(i, j) * v$j - conjugate (v$i) * A$$(i, j) * v$j)) = (∑j=0..<m.(
conjugate (v$i) * (X n $$(i, j)-A$$(i, j)) * v$j))" by auto
have "∀ i < m. ∀ j < m. cmod(conjugate (v $ i) * (X n $$ (i, j) - A $$ (i, j)) * v $ j) =
cmod(conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod(v $ j)"
by (simp add: norm_mult)
then have less: "∀ i < m.(∑j = 0..<m. cmod(conjugate (v $ i) * (X n $$ (i, j) - A $$ (i, j)) * v $ j)) =
(∑j = 0..<m. cmod(conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod(v $ j))" by auto
have "inner_prod v (X n *⇩v v) - inner_prod v (A *⇩v v) = (∑i=0..<m. (∑j=0..<m.
conjugate (v$i) * X n $$(i, j) * v$j)) - (∑i=0..<m. (∑j=0..<m.
conjugate (v$i) * A$$(i, j) * v$j))" using quadratic_form_mat neg dimA dimX by auto
also have "… = (∑i=0..<m. (∑j=0..<m.(
conjugate (v$i) * X n $$(i, j) * v$j - conjugate (v$i) * A$$(i, j) * v$j)))"
using sum_subtractff[of "λ i j. conjugate (v $ i) * X n $$ (i, j) * v $ j" "λ i j. conjugate (v $ i) * A $$ (i, j) * v $ j" "{0..<m}"] by auto
also have "… = (∑i=0..<m. (∑j=0..<m.(
conjugate (v$i) * (X n $$(i, j)-A$$(i, j)) * v$j)))" using ele by auto
finally have minusXA: "inner_prod v (X n *⇩v v) - inner_prod v (A *⇩v v) = (∑i = 0..<m. ∑j = 0..<m. conjugate (v $ i) * (X n $$ (i, j) - A $$ (i, j)) * v $ j)" by auto
from minusXA have "cmod (inner_prod v (X n *⇩v v) - inner_prod v (A *⇩v v)) =
cmod (∑i = 0..<m. ∑j = 0..<m. conjugate (v $ i) * (X n $$ (i, j) - A $$ (i, j)) * v $ j)" by auto
also have "… ≤ (∑i = 0..<m. ∑j = 0..<m. cmod(conjugate (v $ i) * (X n $$ (i, j) - A $$ (i, j)) * v $ j))"
using sum_abs_complex by simp
also have "… = (∑i = 0..<m. ∑j = 0..<m. cmod(conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod(v $ j))"
using less by auto
finally show ?thesis by auto
qed
from limij have limijm: " ∀i<m. ∀j<m. ∀r>0. ∃no. ∀n≥no. cmod (X n $$ (i, j) - A $$ (i, j)) < r"
unfolding LIMSEQ_def dist_norm by auto
from limX have mg: "m > 0" using limit_mat_def
by (metis carrier_matD(1) carrier_matD(2) mat_eq_iff neq0_conv not_less0 npA posX)
have cmoda: "∃no. ∀n≥no. (∑i = 0..<m. ∑j = 0..<m. cmod (conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod (v $ j)) < r"
if r: "r > 0" for r
proof -
let ?u = "(∑i = 0..<m. ∑j = 0..<m.((cmod (conjugate (v $ i)) * cmod (v $ j))))"
have ug: "?u > 0"
proof -
have ur: "?u = (∑i = 0..<m. (cmod (conjugate (v $ i)) * (∑j = 0..<m.( cmod (v $ j)))))" by (simp add: sum_distrib_left)
have "(∑j = 0..<m.( cmod (v $ j))) ≥ cmod (v $ i)" if i: "i < m" for i
using member_le_sum[of i "{0..<m}" "λ j. cmod (v$j)"] cmod_def i by simp
then have "∀ i < m. (cmod (conjugate (v $ i)) * (∑j = 0..<m.( cmod (v $ j)))) ≥ (cmod (conjugate (v $ i)) * cmod (v $ i))"
by (simp add: mult_left_mono)
then have "?u ≥ (∑i = 0..<m. (cmod (conjugate (v $ i)) *cmod (v $ i)))"
using ur sum_mono[of "{0..<m}" "λ i. cmod (conjugate (v $ i)) * cmod (v $ i)" "λ i. cmod (conjugate (v $ i)) * (∑j = 0..<m. cmod (v $ j))"]
by auto
moreover have "(∑i = 0..<m. cmod (conjugate (v $ i) *cmod (v $ i))) = (∑i = 0..<m. cmod (conjugate (v $ i) * (v $ i)))"
using norm_ge_zero norm_mult norm_of_real by (metis (no_types, hide_lams) abs_of_nonneg)
moreover have "(∑i = 0..<m. cmod (conjugate (v $ i) * (v $ i))) = inner_prod v v" using invv by auto
ultimately have "?u ≥ inner_prod v v"
by (metis (no_types, lifting) Im_complex_of_real Re_complex_of_real invv less_eq_complex_def norm_mult sum.cong)
then have "?u > 0" using invgeq by auto
then show ?thesis by auto
qed
let ?s = "r / (2 * ?u)"
have sgz: "?s > 0" using ug rl
by (smt divide_pos_pos dual_order.strict_iff_order linordered_semiring_strict_class.mult_pos_pos zero_less_norm_iff r)
from limijm have sij: "∃no. ∀n≥no. cmod (X n $$ (i, j) - A $$ (i, j)) < ?s" if i: "i < m" and j: "j < m" for i j
proof -
obtain N where Ns: "∀n≥N. cmod (X n $$ (i, j) - A $$ (i, j)) < ?s" using sgz limijm i j by blast
then show ?thesis by auto
qed
then have "∃no. ∀i<m. ∀j<m. ∀n≥no. cmod (X n $$ (i, j) - A $$ (i, j)) < ?s"
using quantifier_change_order_twice[of m m "λ n i j. (cmod (X n $$ (i, j) - A $$ (i, j))<?s)"] by auto
then obtain N where Nno: "∀i<m. ∀j<m. ∀n≥N. cmod (X n $$ (i, j) - A $$ (i, j)) < ?s" by auto
then have mmN: "cmod (conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod (v $ j)
≤ ?s * (cmod (conjugate (v $ i)) * cmod (v $ j))"
if i: "i < m" and j: "j < m" and n: "n ≥ N" for i j n
proof -
have geq: "cmod (conjugate (v $ i)) ≥ 0 ∧ cmod (v $ j)≥0" by simp
then have "cmod (conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) ≤cmod (conjugate (v $ i)) * ?s" using Nno i j n
by (smt mult_left_mono)
then have "cmod (conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod (v $ j)
≤ cmod (conjugate (v $ i)) *?s * cmod (v $ j)" using geq mult_right_mono by blast
also have "… = ?s * (cmod (conjugate (v $ i)) * cmod (v $ j))" by simp
finally show ?thesis by auto
qed
then have "(∑i = 0..<m. ∑j = 0..<m. cmod (conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod (v $ j)) < r"
if n: "n ≥ N" for n
proof -
have mmX: "∀i<m. ∀j<m. cmod (conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod (v $ j)
≤ ?s * (cmod (conjugate (v $ i)) * cmod (v $ j))" using n mmN by blast
have "(∑j = 0..<m. cmod (conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod (v $ j))
≤ (∑j = 0..<m.(?s * (cmod (conjugate (v $ i)) * cmod (v $ j))))" if i: "i < m" for i
proof -
have "∀j<m. cmod (conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod (v $ j)
≤ ?s * (cmod (conjugate (v $ i)) * cmod (v $ j))" using mmX i by auto
then show ?thesis
using sum_mono[of "{0..<m}" "λ j. cmod (conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod (v $ j)" "λ j. (?s * (cmod (conjugate (v $ i)) * cmod (v $ j)))"]
atLeastLessThan_iff by blast
qed
then have "(∑i = 0..<m. ∑j = 0..<m. cmod (conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod (v $ j))
≤ (∑i = 0..<m. ∑j = 0..<m.(?s * (cmod (conjugate (v $ i)) * cmod (v $ j))))" using sum_mono atLeastLessThan_iff
by (metis (no_types, lifting))
also have "… = ?s * (∑i = 0..<m. ∑j = 0..<m.((cmod (conjugate (v $ i)) * cmod (v $ j))))" by (simp add: sum_distrib_left)
also have "… = r / 2" using nonzero_mult_divide_mult_cancel_right sgz by fastforce
finally show ?thesis using r by auto
qed
then show ?thesis by auto
qed
then have XnAv:"∃no. ∀n≥no. cmod (inner_prod v (X n *⇩v v) - inner_prod v (A *⇩v v)) < r" if r: "r > 0" for r
proof -
obtain no where nno: "∀n≥no. (∑i = 0..<m. ∑j = 0..<m. cmod (conjugate (v $ i)) * cmod (X n $$ (i, j) - A $$ (i, j)) * cmod (v $ j)) < r"
using r cmoda neg by auto
then have "∀n≥no. cmod (inner_prod v (X n *⇩v v) - inner_prod v (A *⇩v v)) < r" using XAless neg by smt
then show ?thesis by auto
qed
then have "(λn. inner_prod v (X n *⇩v v)) ⇢ inner_prod v (A *⇩v v)" unfolding LIMSEQ_def dist_norm by auto
then show ?thesis by auto
qed
from limXv have "∀r>0. ∃no. ∀n≥no. cmod (inner_prod v (X n *⇩v v) - inner_prod v (A *⇩v v)) < r" unfolding LIMSEQ_def dist_norm by auto
then have "∃no. ∀n≥no. cmod (inner_prod v (X n *⇩v v) - inner_prod v (A *⇩v v)) < -?r" using rl by auto
then obtain N where Ng: "∀n≥N. cmod (inner_prod v (X n *⇩v v) - inner_prod v (A *⇩v v)) < -?r" by auto
then have XN: "cmod (inner_prod v (X N *⇩v v) - inner_prod v (A *⇩v v)) < -?r" by auto
from posX have "positive (X N)" by auto
then have XNv:"inner_prod v (X N *⇩v v) ≥ 0"
by (metis Complex_Matrix.positive_def carrier_matD(2) dimA dimX neg)
from rl XNv have XX: "cmod (inner_prod v (X N *⇩v v) - inner_prod v (A *⇩v v)) = cmod(inner_prod v (X N *⇩v v)) - cmod(inner_prod v (A *⇩v v))"
using XN cmod_eq_Re by auto
then have YY: "cmod(inner_prod v (X N *⇩v v)) - cmod(inner_prod v (A *⇩v v)) < -?r" using XN by auto
then have "cmod(inner_prod v (X N *⇩v v)) - cmod(inner_prod v (A *⇩v v)) < cmod(inner_prod v (A *⇩v v))" using rl cmod_eq_Re by auto
then have "cmod(inner_prod v (X N *⇩v v)) < 0" using XNv XX YY cmod_eq_Re by auto
then have "False" using XNv by simp
with npA show False by auto
qed
lemma limit_mat_ignore_initial_segment:
"limit_mat g A d ⟹ limit_mat (λn. g (n + k)) A d"
proof -
assume asm: "limit_mat g A d"
then have lim: "∀ i < d. ∀ j < d. (λ n. (g n) $$ (i, j)) ⇢ (A $$ (i, j))" using limit_mat_def by auto
then have limk: "∀ i < d. ∀ j < d. (λ n. (g (n + k)) $$ (i, j)) ⇢ (A $$ (i, j))"
proof -
{
fix i j assume dims: "i < d" "j < d"
then have "(λ n. (g n) $$ (i, j)) ⇢ (A $$ (i, j))" using lim by auto
then have "(λ n. (g (n + k)) $$ (i, j)) ⇢ (A $$ (i, j))" using LIMSEQ_ignore_initial_segment by auto
}
then show "∀ i < d. ∀ j < d. (λ n. (g (n + k)) $$ (i, j)) ⇢ (A $$ (i, j))" by auto
qed
have "∀ n. g n ∈ carrier_mat d d" using asm unfolding limit_mat_def by auto
then have "∀ n. g (n + k) ∈ carrier_mat d d" by auto
moreover have "A ∈ carrier_mat d d" using asm limit_mat_def by auto
ultimately show "limit_mat (λn. g (n + k)) A d" using limit_mat_def limk by auto
qed
lemma mat_trace_limit:
"limit_mat g A d ⟹ (λn. trace (g n)) ⇢ trace A"
proof -
assume lim: "limit_mat g A d"
then have dgn: "g n ∈ carrier_mat d d" for n using limit_mat_def by auto
from lim have dA: "A ∈ carrier_mat d d" using limit_mat_def by auto
have trg: "trace (g n) = (∑k=0..<d. (g n)$$(k, k))" for n unfolding trace_def using carrier_matD[OF dgn] by auto
have "∀k < d. (λn. (g n)$$(k, k)) ⇢ A$$(k, k)" using limit_mat_def lim by auto
then have "(λn. (∑k=0..<d. (g n)$$(k, k))) ⇢ (∑k=0..<d. A$$(k, k))"
using tendsto_sum[where ?I = "{0..<d}" and ?f = "(λk n. (g n)$$(k, k))"] by auto
then show "(λn. trace (g n)) ⇢ trace A" unfolding trace_def
using trg carrier_matD[OF dgn] carrier_matD[OF dA] by auto
qed
subsection ‹Existence of least upper bound for the L\"{o}wner order›
definition lowner_is_lub :: "(nat ⇒ complex mat) ⇒ complex mat ⇒ bool" where
"lowner_is_lub f M ⟷ (∀n. f n ≤⇩L M) ∧ (∀M'. (∀n. f n ≤⇩L M') ⟶ M ≤⇩L M')"
locale matrix_seq =
fixes dim :: nat
and f :: "nat ⇒ complex mat"
assumes
dim: "⋀n. f n ∈ carrier_mat dim dim" and
pdo: "⋀n. partial_density_operator (f n)" and
inc: "⋀n. lowner_le (f n) (f (Suc n))"
begin
definition lowner_is_lub :: "complex mat ⇒ bool" where
"lowner_is_lub M ⟷ (∀n. f n ≤⇩L M) ∧ (∀M'. (∀n. f n ≤⇩L M') ⟶ M ≤⇩L M')"
lemma lowner_is_lub_dim:
assumes "lowner_is_lub M"
shows "M ∈ carrier_mat dim dim"
proof -
have "f 0 ≤⇩L M" using assms lowner_is_lub_def by auto
then have 1: "dim_row (f 0) = dim_row M ∧ dim_col (f 0) = dim_col M"
using lowner_le_def by auto
moreover have 2: "f 0 ∈ carrier_mat dim dim"
using dim by auto
ultimately show ?thesis by auto
qed
lemma trace_adjoint_eq_u:
fixes A :: "complex mat"
shows "trace (A * adjoint A) = (∑ i ∈ {0 ..< dim_row A}. ∑ j ∈ {0 ..< dim_col A}. (norm(A $$ (i,j)))⇧2)"
proof -
have "trace (A * adjoint A) = (∑ i ∈ {0 ..< dim_row A}. row A i ∙ conjugate (row A i))"
by (simp add: trace_def cmod_def adjoint_def scalar_prod_def)
also have "… = (∑ i ∈ {0 ..< dim_row A}. ∑ j ∈ {0 ..< dim_col A}. (norm(A $$ (i,j)))⇧2)"
proof (simp add: scalar_prod_def cmod_def)
have cnjmul: "∀ i ia. A $$ (i, ia) * cnj (A $$ (i, ia)) =
((complex_of_real (Re (A $$ (i, ia))))⇧2 + (complex_of_real (Im (A $$ (i, ia))))⇧2)"
by (simp add: complex_mult_cnj)
then have "∀ i. (∑ia = 0..<dim_col A. A $$ (i, ia) * cnj (A $$ (i, ia))) =
(∑ia = 0..<dim_col A. ((complex_of_real (Re (A $$ (i, ia))))⇧2 + (complex_of_real (Im (A $$ (i, ia))))⇧2))"
by auto
then show"(∑i = 0..<dim_row A. ∑ia = 0..<dim_col A. A $$ (i, ia) * cnj (A $$ (i, ia))) =
(∑x = 0..<dim_row A. ∑xa = 0..<dim_col A. (complex_of_real (Re (A $$ (x, xa))))⇧2) +
(∑x = 0..<dim_row A. ∑xa = 0..<dim_col A. (complex_of_real (Im (A $$ (x, xa))))⇧2)"
by auto
qed
finally show ?thesis .
qed
lemma trace_adjoint_element_ineq:
fixes A :: "complex mat"
assumes rindex: "i ∈ {0 ..< dim_row A}"
and cindex: "j ∈ {0 ..< dim_col A}"
shows "(norm(A $$ (i,j)))⇧2 ≤ trace (A * adjoint A)"
proof (simp add: trace_adjoint_eq_u)
have ineqi: "(cmod (A $$ (i, j)))⇧2 ≤ (∑xa = 0..<dim_col A. (cmod (A $$ (i, xa)))⇧2)"
using cindex member_le_sum[of j " {0 ..< dim_col A}" "λ x. (cmod (A $$ (i, x)))⇧2"] by auto
also have ineqj: "… ≤ (∑x = 0..<dim_row A. ∑xa = 0..<dim_col A. (cmod (A $$ (x, xa)))⇧2)"
using rindex member_le_sum[of i " {0 ..< dim_row A}" "λ x. ∑xa = 0..<dim_col A. (cmod (A $$ (x, xa)))⇧2"]
by (simp add: sum_nonneg)
then show "(cmod (A $$ (i, j)))⇧2 ≤ (∑x = 0..<dim_row A. ∑xa = 0..<dim_col A. (cmod (A $$ (x, xa)))⇧2)"
using ineqi by linarith
qed
lemma positive_is_normal:
fixes A :: "complex mat"
assumes pos: "positive A"
shows "A * adjoint A = adjoint A * A"
proof -
have hA: "hermitian A" using positive_is_hermitian pos by auto
then show ?thesis by (simp add: hA hermitian_is_normal)
qed
lemma diag_mat_mul_diag_diag:
fixes A B :: "complex mat"
assumes dimA: "A ∈ carrier_mat n n" and dimB: "B ∈ carrier_mat n n"
and dA: "diagonal_mat A" and dB: "diagonal_mat B"
shows "diagonal_mat (A * B)"
proof -
have AB: "A * B = mat n n (λ(i,j). (if (i = j) then (A$$(i, i)) * (B$$(i, i)) else 0))"
using diag_mat_mult_diag_mat[of A n B] dimA dimB dA dB by auto
then have dAB: "∀i<n. ∀j<n. i ≠ j ⟶ (A*B) $$ (i,j) = 0"
proof -
{
fix i j assume i: "i < n" and j: "j < n" and ij: "i ≠ j"
have "(A*B) $$ (i,j) = 0" using AB i j ij by auto
}
then show ?thesis by auto
qed
then show ?thesis using diagonal_mat_def dAB dimA dimB
by (metis carrier_matD(1) carrier_matD(2) index_mult_mat(2) index_mult_mat(3))
qed
lemma diag_mat_mul_diag_ele:
fixes A B :: "complex mat"
assumes dimA: "A ∈ carrier_mat n n" and dimB: "B ∈ carrier_mat n n"
and dA: "diagonal_mat A" and dB: "diagonal_mat B"
shows "∀i<n. (A*B) $$ (i,i) = A$$(i, i) * B$$(i, i)"
proof -
have AB: "A * B = mat n n (λ(i,j). if i = j then (A$$(i, i)) * (B$$(i, i)) else 0)"
using diag_mat_mult_diag_mat[of A n B] dimA dimB dA dB by auto
then show ?thesis
using AB by auto
qed
lemma trace_square_less_square_trace:
fixes B :: "complex mat"
assumes dimB: "B ∈ carrier_mat n n"
and dB: "diagonal_mat B" and pB: "⋀i. i < n ⟹ B$$(i, i) ≥ 0"
shows "trace (B*B) ≤ (trace B)⇧2"
proof -
have tB: "trace B = (∑ i ∈ {0 ..<n}. B $$ (i,i))" using assms trace_def[of B] carrier_mat_def by auto
then have tBtB: "(trace B)⇧2 = (∑ i ∈ {0 ..<n}.∑ j ∈ {0 ..<n}. B $$ (i,i)*B $$ (j,j))"
proof -
show ?thesis
by (metis (no_types) semiring_normalization_rules(29) sum_product tB)
qed
have BB: "⋀i. i < n ⟹ (B*B) $$ (i,i) = (B$$(i, i))⇧2" using diag_mat_mul_diag_ele[of B n B] dimB dB
by (metis numeral_1_eq_Suc_0 power_Suc0_right power_add_numeral semiring_norm(2))
have tBB: "trace (B*B) = (∑ i ∈ {0 ..<n}. (B*B) $$ (i,i))" using assms trace_def[of "B*B"] carrier_mat_def by auto
also have "… = (∑ i ∈ {0 ..<n}. (B$$(i, i))⇧2)" using BB by auto
finally have BBt: " trace (B * B) = (∑i = 0..<n. (B $$ (i, i))⇧2)" by auto
have lesseq: "∀i ∈ {0 ..<n}. (B $$ (i, i))⇧2 ≤ (∑ j ∈ {0 ..<n}. B $$ (i,i)*B $$ (j,j))"
proof -
{
fix i assume i: "i < n"
have "(∑j = 0..<n. B $$ (i, i) * B $$ (j, j)) = (B $$ (i, i))⇧2 + sum (λ j. (B $$ (i, i) * B $$ (j, j))) ({0 ..<n} - {i})"
by (metis (no_types, lifting) BB atLeastLessThan_iff dB diag_mat_mul_diag_ele dimB finite_atLeastLessThan i not_le not_less_zero sum.remove)
moreover have "(sum (λ j. (B $$ (i, i) * B $$ (j, j))) ({0 ..<n} - {i})) ≥ 0"
proof (cases "{0..<n} - {i} ≠ {}")
case True
then show ?thesis using pB i sum_nonneg[of "{0..<n} - {i}" "λ j. (B $$ (i, i) * B $$ (j, j))"] by auto
next
case False
have "(∑j∈{0..<n} - {i}. B $$ (i, i) * B $$ (j, j)) = 0" using False by fastforce
then show ?thesis by auto
qed
ultimately have "(∑j = 0..<n. B $$ (i, i) * B $$ (j, j)) ≥ (B $$ (i, i))⇧2" by auto
}
then show ?thesis by auto
qed
from tBtB BBt lesseq have "trace (B*B) ≤ (trace B)⇧2"
using sum_mono[of "{0..<n}" "λ i. (B $$ (i, i))⇧2" "λ i. (∑j = 0..<n. B $$ (i, i) * B $$ (j, j))"]
by (metis (no_types, lifting))
then show ?thesis by auto
qed
lemma trace_positive_eq:
fixes A :: "complex mat"
assumes pos: "positive A"
shows "trace (A * adjoint A) ≤ (trace A)⇧2"
proof -
from assms have normal: "A * adjoint A = adjoint A * A" by (rule positive_is_normal)
moreover
from assms positive_dim_eq obtain n where cA: "A ∈ carrier_mat n n" by auto
moreover
from assms complex_mat_char_poly_factorizable cA obtain es where charpo: " char_poly A = (∏ a ← es. [:- a, 1:]) ∧ length es = n" by auto
moreover
obtain B P Q where B: "unitary_schur_decomposition A es = (B,P,Q)" by (cases "unitary_schur_decomposition A es", auto)
ultimately have
smw: "similar_mat_wit A B P (adjoint P)"
and ut: "diagonal_mat B"
and uP: "unitary P"
and dB: "diag_mat B = es"
and QaP: "Q = adjoint P"
using normal_complex_mat_has_spectral_decomposition[of A n es B P Q] unitary_schur_decomposition by auto
from smw cA QaP uP have cB: "B ∈ carrier_mat n n" and cP: "P ∈ carrier_mat n n" and cQ: "Q ∈ carrier_mat n n"
unfolding similar_mat_wit_def Let_def unitary_def by auto
then have caP: "adjoint P ∈ carrier_mat n n" using adjoint_dim[of P n] by auto
from smw QaP cA have A: "A = P * B * adjoint P" and traceA: "trace A = trace (P * B * Q)" and PB: "P * Q = 1⇩m n ∧ Q * P = 1⇩m n"
unfolding similar_mat_wit_def by auto
have traceAB: "trace (P * B * Q) = trace ((Q*P)*B)"
using cQ cP cB by (mat_assoc n)
also have traceelim: "… = trace B" using traceAB PB cA cB cP cQ left_mult_one_mat[of "P*Q" n n]
using similar_mat_wit_sym by auto
finally have traceAB: "trace A = trace B" using traceA by auto
from A cB cP have aAa: "adjoint A = adjoint((P * B) * adjoint P)" by auto
have aA: "adjoint A = P * adjoint B * adjoint P"
unfolding aAa using cP cB by (mat_assoc n)
have hA: "hermitian A" using pos positive_is_hermitian by auto
then have AaA: "A = adjoint A" using hA hermitian_def[of A] by auto
then have PBaP: "P * B * adjoint P = P * adjoint B * adjoint P" using A aA by auto
then have BaB: "B = adjoint B" using unitary_elim[of B n "adjoint B" P] uP cP cB adjoint_dim[of B n] by auto
have aPP: "adjoint P * P = 1⇩m n" using uP PB QaP by blast
have "A * A = P * B * (adjoint P * P) * B * adjoint P"
unfolding A using cP cB by (mat_assoc n)
also have "… = P * B * B * adjoint P"
unfolding aPP using cP cB by (mat_assoc n)
finally have AA: "A * A = P * B * B * adjoint P" by auto
then have tAA: "trace (A*A) = trace (P * B * B * adjoint P)" by auto
also have tBB: "… = trace (adjoint P * P * B * B)" using cP cB by (mat_assoc n)
also have "… = trace (B * B)" using uP unitary_def[of P] inverts_mat_def[of P "adjoint P"]
using PB QaP cB by auto
finally have traceAABB: "trace (A * A) = trace (B * B)" by auto
have BP: "⋀i. i < n ⟹ B$$(i, i) ≥ 0"
proof -
{
fix i assume i: "i < n"
then have "B$$(i, i) ≥ 0" using positive_eigenvalue_positive[of A n es B P Q i] cA pos charpo B by auto
then show "B$$(i, i) ≥ 0" by auto
}
qed
have Brel: "trace (B*B) ≤ (trace B)⇧2" using trace_square_less_square_trace[of B n] cB ut BP by auto
from AaA traceAABB traceAB Brel have "trace (A*adjoint A) ≤ (trace A)⇧2" by auto
then show ?thesis by auto
qed
lemma lowner_le_transitive:
fixes m n :: nat
assumes re: "n ≥ m"
shows "positive (f n - f m)"
proof -
from re show "positive (f n - f m)"
proof (induct n)
case 0
then show ?case using positive_zero
by (metis dim le_0_eq minus_r_inv_mat)
next
case (Suc n)
then show ?case
proof (cases "Suc n = m")
case True
then show ?thesis using positive_zero
by (metis dim minus_r_inv_mat)
next
case False
then show ?thesis
proof -
from False Suc have nm: "n ≥ m" by linarith
from Suc nm have pnm: "positive (f n - f m)" by auto
from inc have "positive (f (Suc n) - f n)" unfolding lowner_le_def by auto
then have pf: "positive ((f (Suc n) - f n) + (f n - f m))" using positive_add dim pnm
by (meson minus_carrier_mat)
have "(f (Suc n) - f n) + (f n - f m) = f (Suc n) + ((- f n) + f n) + (- f m)"
using local.dim by (mat_assoc dim, auto)
also have "… = f (Suc n) + 0⇩m dim dim + (- f m)"
using local.dim by (subst uminus_l_inv_mat[where nc=dim and nr=dim], auto)
also have "… = f (Suc n) - f m"
using local.dim by (mat_assoc dim, auto)
finally have re: "f (Suc n) - f n + (f n - f m) = f (Suc n) - f m" .
from pf re have "positive (f (Suc n) - f m)" by auto
then show ?thesis by auto
qed
qed
qed
qed
text ‹The sequence of matrices converges pointwise.›
lemma inc_partial_density_operator_converge:
assumes i: "i ∈ {0 ..<dim}" and j: "j ∈ {0 ..<dim}"
shows "convergent (λn. f n $$ (i, j))"
proof-
have tracefn: "trace (f n) ≥ 0 ∧ trace (f n) ≤ 1" for n
proof -
from pdo show ?thesis
unfolding partial_density_operator_def using positive_trace[of "f n"]
using dim by blast
qed
from tracefn have normf: "norm(trace (f n)) ≤ norm(trace (f (Suc n))) ∧ norm(trace (f n)) ≤ 1" for n
proof -
have trless: "trace (f n) ≤ trace (f (Suc n))"
using pdo inc dim positive_trace[of "f(Suc n) - f n"] trace_minus_linear[of "f (Suc n)" dim "f n"]
unfolding partial_density_operator_def lowner_le_def
using Complex_Matrix.positive_def by force
moreover from trless tracefn have "norm(trace (f n)) ≤ norm(trace (f (Suc n)))" unfolding cmod_def by simp
moreover from trless tracefn have "norm(trace (f n)) ≤ 1" using pdo partial_density_operator_def cmod_def by simp
ultimately show ?thesis by auto
qed
then have inctrace: "incseq (λ n. norm(trace (f n)))" by (simp add: incseq_SucI)
then have tr_sup: "(λ n. norm(trace (f n))) ⇢ (SUP i. norm (trace (f i)))"
using LIMSEQ_incseq_SUP[of "λ n. norm(trace (f n))"] pdo partial_density_operator_def normf by (meson bdd_aboveI2)
then have tr_cauchy: "Cauchy (λ n. norm(trace (f n)))" using Cauchy_convergent_iff convergent_def by blast
then have tr_cauchy_def: "∀e>0. ∃M. ∀m≥M. ∀n≥M. dist(norm(trace (f n))) (norm(trace (f m))) < e" unfolding Cauchy_def by blast
moreover have "∀m n. dist(norm(trace (f m))) (norm(trace (f n))) = norm(trace (f m) - trace (f n))"
using tracefn cmod_eq_Re dist_real_def by auto
ultimately have norm_trace: "∀e>0.∃M. ∀m≥M. ∀n≥M. norm((trace (f n)) - (trace (f m))) < e" by auto
have eq_minus: "∀ m n. trace (f m) - trace (f n) = trace (f m - f n)" using trace_minus_linear dim by metis
from eq_minus norm_trace have norm_trace_cauchy: "∀e>0.∃M. ∀m≥M. ∀n≥M. norm((trace (f n - f m))) < e" by auto
then have norm_trace_cauchy_iff: "∀e>0.∃M. ∀m≥M. ∀n≥m. norm((trace (f n - f m))) < e"
by (meson order_trans_rules(23))
then have norm_square: "∀e>0.∃M. ∀m≥M. ∀n≥m. (norm((trace (f n - f m))))⇧2 < e⇧2"
by (metis abs_of_nonneg norm_ge_zero order_less_le real_sqrt_abs real_sqrt_less_iff)
have tr_re: "∀ m. ∀ n ≥ m. trace ((f n - f m) * adjoint (f n - f m)) ≤ ((trace (f n- f m)))⇧2"
using trace_positive_eq lowner_le_transitive by auto
have tr_re_g: "∀ m. ∀ n ≥ m. trace ((f n - f m) * adjoint (f n - f m)) ≥ 0"
using lowner_le_transitive positive_trace trace_adjoint_positive by auto
have norm_trace_fmn: "norm(trace ((f n - f m) * adjoint (f n - f m))) ≤ (norm(trace (f n - f m)))⇧2" if nm: "n ≥ m" for m n
proof -
have mnA: "trace ((f n - f m) * adjoint (f n - f m)) ≤ (trace (f n - f m))⇧2" using tr_re nm by auto
have mnB: "trace ((f n - f m) * adjoint (f n - f m)) ≥ 0" using tr_re_g nm by auto
from mnA mnB show ?thesis
by (smt cmod_eq_Re less_eq_complex_def norm_power zero_complex.sel(1) zero_complex.sel(2))
qed
then have cauchy_adj: "∃M. ∀m≥M. ∀n≥m. norm(trace ((f n- f m) * adjoint (f n - f m))) < e⇧2" if e: "e > 0" for e
proof -
have "∃M. ∀m≥M. ∀n≥m. (cmod (trace (f n - f m)))⇧2 < e⇧2" using norm_square e by auto
then obtain M where " ∀m≥M. ∀n≥m. (cmod (trace (f n - f m)))⇧2 < e⇧2" by auto
then have "∀m≥M. ∀n≥m. norm(trace ((f n- f m) * adjoint (f n - f m))) < e⇧2" using norm_trace_fmn by fastforce
then show ?thesis by auto
qed
have norm_minus: "∀ m. ∀ n ≥ m. (norm ((f n - f m) $$ (i, j)))⇧2 ≤ trace ((f n - f m) * adjoint (f n - f m))"
using trace_adjoint_element_ineq i j
by (smt adjoint_dim_row carrier_matD(1) index_minus_mat(2) index_mult_mat(2) lowner_le_transitive matrix_seq_axioms matrix_seq_def positive_is_normal)
then have norm_minus_le: "(norm ((f n - f m) $$ (i, j)))⇧2 ≤ norm (trace ((f n - f m) * adjoint (f n - f m)))" if nm: "n ≥ m" for n m
proof -
have "(norm ((f n - f m) $$ (i, j)))⇧2 ≤ (trace ((f n - f m) * adjoint (f n - f m)))" using norm_minus nm by auto
also have "… = norm (trace ((f n - f m) * adjoint (f n - f m)))" using tr_re_g nm
by (smt Re_complex_of_real less_eq_complex_def matrix_seq.trace_adjoint_eq_u matrix_seq_axioms mult_cancel_left2 norm_one norm_scaleR of_real_def of_real_hom.hom_zero)
finally show ?thesis by auto
qed
from norm_minus_le cauchy_adj have cauchy_ij: "∃M. ∀m≥M. ∀n≥m. (norm ((f n - f m) $$ (i, j)))⇧2 < e⇧2" if e: "e > 0" for e
proof -
have "∃M. ∀m≥M. ∀n≥m. norm(trace ((f n- f m) * adjoint (f n - f m))) < e⇧2" using cauchy_adj e by auto
then obtain M where " ∀m≥M. ∀n≥m. norm(trace ((f n - f m) * adjoint (f n - f m))) < e⇧2" by auto
then have "∀m≥M. ∀n≥m. (norm ((f n - f m) $$ (i, j)))⇧2 < e⇧2" using norm_minus_le by fastforce
then show ?thesis by auto
qed
then have cauchy_ij_norm: "∃M. ∀m≥M. ∀n≥m. (norm ((f n - f m) $$ (i, j))) < e" if e: "e > 0" for e
proof -
have "∃M. ∀m≥M. ∀n≥m. (norm ((f n - f m) $$ (i, j)))⇧2 < e⇧2" using cauchy_ij e by auto
then obtain M where mn: "∀m≥M. ∀n≥m. (norm ((f n - f m) $$ (i, j)))⇧2 < e⇧2" by auto
have "(norm ((f n - f m) $$ (i, j))) < e" if m: "m ≥ M" and n: "n ≥ m" for m n :: nat
proof -
from m n mn have "(norm ((f n- f m) $$ (i, j)))⇧2 < e⇧2" by auto
then show ?thesis
using e power_less_imp_less_base by fastforce
qed
then show ?thesis by auto
qed
have cauchy_final: "∃M. ∀m≥M. ∀n≥M. norm ((f m) $$ (i, j) - (f n) $$ (i, j)) < e" if e: "e > 0" for e
proof -
obtain M where mnm: "∀m≥M. ∀n≥m. norm ((f n - f m) $$ (i, j)) < e" using cauchy_ij_norm e by auto
have "norm ((f m) $$ (i, j) - (f n) $$ (i, j)) < e" if m: "m ≥ M" and n: "n ≥ M" for m n
proof (cases "n ≥ m")
case True
then show ?thesis
proof -
from mnm m True have "norm ((f n) $$ (i, j) - (f m) $$ (i, j)) < e"
by (metis atLeastLessThan_iff carrier_matD(1) carrier_matD(2) dim i index_minus_mat(1) j)
then have "norm ((f m) $$ (i, j) - (f n) $$ (i, j)) < e" by (simp add: norm_minus_commute)
then show ?thesis by auto
qed
next
case False
then show ?thesis
proof -
from False n mnm have norm: "norm ((f m - f n) $$ (i, j)) < e" by auto
have minus: "(f m - f n) $$ (i, j) = f m $$ (i, j) -f n $$ (i, j)"
by (metis atLeastLessThan_iff carrier_matD(1) carrier_matD(2) dim i index_minus_mat(1) j)
also have "… = - (f n - f m) $$ (i, j)" using dim
by (metis atLeastLessThan_iff carrier_matD(1) carrier_matD(2) i index_minus_mat(1) j minus_diff_eq)
finally have fmn: "(f m - f n) $$ (i, j) = - (f n - f m) $$ (i, j)" by auto
then have "norm ((- (f n - f m)) $$ (i, j)) < e" using norm
by (metis (no_types, lifting) atLeastLessThan_iff carrier_matD(1) carrier_matD(2) i
index_minus_mat(2) index_minus_mat(3) index_uminus_mat(1) j matrix_seq_axioms matrix_seq_def)
then have "norm (((f n - f m)) $$ (i, j)) < e" using fmn norm by auto
then have "norm (f n $$ (i, j) - f m $$ (i, j)) < e"
by (metis minus norm norm_minus_commute)
then have "norm (f m $$ (i, j) - f n $$ (i, j)) < e" by (simp add: norm_minus_commute)
then show ?thesis by auto
qed
qed
then show ?thesis by auto
qed
from cauchy_final have "Cauchy (λ n. f n $$ (i, j))" by (simp add: Cauchy_def dist_norm)
then show ?thesis by (simp add: Cauchy_convergent_iff)
qed
definition mat_seq_minus :: "(nat ⇒ complex mat) ⇒ complex mat ⇒ nat ⇒ complex mat" where
"mat_seq_minus X A = (λn. X n - A)"
definition minus_mat_seq :: "complex mat ⇒ (nat ⇒ complex mat) ⇒ nat ⇒ complex mat" where
"minus_mat_seq A X = (λn. A - X n)"
lemma pos_mat_lim_is_pos_aux:
fixes X :: "nat ⇒ complex mat" and A :: "complex mat" and m :: nat
assumes limX: "limit_mat X A m" and posX: "∃k. ∀n≥k. positive (X n)"
shows "positive A"
proof -
from posX obtain k where posk: "∀ n≥k. positive (X n)" by auto
let ?Y = "λn. X (n + k)"
have posY: "∀n. positive (?Y n)" using posk by auto
from limX have dimXA: "∀n. X (n + k) ∈ carrier_mat m m ∧ A ∈ carrier_mat m m"
unfolding limit_mat_def by auto
have "(λn. X (n + k) $$ (i, j)) ⇢ A $$ (i, j)" if i: "i < m" and j: "j < m" for i j
proof -
have "(λn. X n $$ (i, j)) ⇢ A $$ (i, j)" using limX limit_mat_def i j by auto
then have limseqX: "∀r>0. ∃no. ∀n≥no. dist (X n $$ (i, j)) (A $$ (i, j)) < r" unfolding LIMSEQ_def by auto
then have "∃no. ∀n≥no. dist (X (n + k) $$ (i, j)) (A $$ (i, j)) < r" if r: "r > 0" for r
proof -
obtain no where "∀n≥no. dist (X n $$ (i, j)) (A $$ (i, j)) < r" using limseqX r by auto
then have "∀n≥no. dist (X (n + k) $$ (i, j)) (A $$ (i, j)) < r" by auto
then show ?thesis by auto
qed
then show ?thesis unfolding LIMSEQ_def by auto
qed
then have limXA: "limit_mat (λn. X (n + k)) A m" unfolding limit_mat_def using dimXA by auto
from posY limXA have "positive A" using pos_mat_lim_is_pos[of ?Y A m] by auto
then show ?thesis by auto
qed
lemma minus_mat_limit:
fixes X :: "nat ⇒ complex mat" and A :: "complex mat" and m :: nat and B :: "complex mat"
assumes dimB: "B ∈ carrier_mat m m" and limX: "limit_mat X A m"
shows "limit_mat (mat_seq_minus X B) (A - B) m"
proof -
have dimXAB: "∀n. X n - B ∈ carrier_mat m m ∧ A - B ∈ carrier_mat m m" using index_minus_mat dimB by auto
have "(λn. (X n - B) $$ (i, j)) ⇢ (A - B) $$ (i, j)" if i: "i < m" and j: "j < m" for i j
proof -
from limX i j have "(λn. (X n) $$ (i, j)) ⇢ (A) $$ (i, j)" unfolding limit_mat_def by auto
then have X: "∀r>0. ∃no. ∀n≥no. dist (X n $$ (i, j)) (A $$ (i, j)) < r" unfolding LIMSEQ_def by auto
then have XB: "∃no. ∀n≥no. dist ((X n - B) $$ (i, j)) ((A - B) $$ (i, j)) < r" if r: "r > 0" for r
proof -
obtain no where "∀n≥no. dist (X n $$ (i, j)) (A $$ (i, j)) < r" using r X by auto
then have dist: "∀n≥no. norm (X n $$ (i, j) - A $$ (i, j)) < r" unfolding dist_norm by auto
then have "norm ((X n - B) $$ (i, j) - (A - B) $$ (i, j)) < r" if n: "n ≥ no" for n
proof -
have "(X n - B) $$ (i, j) - (A - B) $$ (i, j) = (X n) $$ (i, j) - A $$ (i, j)"
using dimB i j by auto
then have "norm ((X n - B) $$ (i, j) - (A - B) $$ (i, j)) = norm ((X n) $$ (i, j) - A $$ (i, j))" by auto
then show ?thesis using dist n by auto
qed
then show ?thesis using dist_norm by metis
qed
then show ?thesis unfolding LIMSEQ_def by auto
qed
then show ?thesis
unfolding limit_mat_def mat_seq_minus_def using dimXAB by auto
qed
lemma mat_minus_limit:
fixes X :: "nat ⇒ complex mat" and A :: "complex mat" and m :: nat and B :: "complex mat"
assumes dimA: "A ∈ carrier_mat m m" and limX: "limit_mat X A m"
shows "limit_mat (minus_mat_seq B X) (B - A) m"
proof-
have dimX : "∀n. X n ∈ carrier_mat m m" using limX unfolding limit_mat_def by auto
then have dimXAB: "∀n. B - X n ∈ carrier_mat m m ∧ B - A ∈ carrier_mat m m" using index_minus_mat dimA
by (simp add: minus_carrier_mat)
have "(λn. (B - X n) $$ (i, j)) ⇢ (B - A) $$ (i, j)" if i: "i < m" and j: "j < m" for i j
proof -
from limX i j have "(λn. (X n) $$ (i, j)) ⇢ (A) $$ (i, j)" unfolding limit_mat_def by auto
then have X: "∀r>0. ∃no. ∀n≥no. dist (X n $$ (i, j)) (A $$ (i, j)) < r" unfolding LIMSEQ_def by auto
then have XB: "∃no. ∀n≥no. dist ((B - X n) $$ (i, j)) ((B - A) $$ (i, j)) < r" if r: "r > 0" for r
proof -
obtain no where "∀n≥no. dist (X n $$ (i, j)) (A $$ (i, j)) < r" using r X by auto
then have dist: "∀n≥no. norm (X n $$ (i, j) - A $$ (i, j)) < r" unfolding dist_norm by auto
then have "norm ((B - X n) $$ (i, j) - (B - A) $$ (i, j)) < r" if n: "n ≥ no" for n
proof -
have "(B - X n) $$ (i, j) - (B - A) $$ (i, j) = - ((X n) $$ (i, j) - A $$ (i, j))"
using dimA i j
by (smt cancel_ab_semigroup_add_class.diff_right_commute cancel_comm_monoid_add_class.diff_cancel carrier_matD(1) carrier_matD(2) diff_add_cancel dimX index_minus_mat(1) minus_diff_eq)
then have "norm ((B - X n) $$ (i, j) - (B - A) $$ (i, j)) = norm ((X n) $$ (i, j) - A $$ (i, j))"
by (metis norm_minus_cancel)
then show ?thesis using dist n by auto
qed
then show ?thesis using dist_norm by metis
qed
then show ?thesis unfolding LIMSEQ_def by auto
qed
then have "limit_mat (minus_mat_seq B X) (B - A) m"
unfolding limit_mat_def minus_mat_seq_def using dimXAB by auto
then show ?thesis by auto
qed
lemma lowner_lub_form:
"lowner_is_lub (mat dim dim (λ (i, j). (lim (λ n. (f n) $$ (i, j)))))"
proof -
from inc_partial_density_operator_converge
have conf: "∀ i ∈ {0 ..<dim}. ∀ j ∈ {0 ..<dim}. convergent (λ n. f n $$ (i, j))" by auto
let ?A = "mat dim dim (λ (i, j). (lim (λ n. (f n) $$ (i, j))))"
have dim_A: "?A ∈ carrier_mat dim dim" by auto
have lim_A: "(λn. f n $$ (i, j)) ⇢ mat dim dim (λ(i, j). lim (λn. f n $$ (i, j))) $$ (i, j)"
if i: "i < dim" and j: "j < dim" for i j
proof -
from i j have ij: "mat dim dim (λ(i, j). lim (λn. f n $$ (i, j))) $$ (i, j) = lim (λn. f n $$ (i, j))"
by (metis case_prod_conv index_mat(1))
have "convergent (λn. f n $$ (i, j))" using conf i j by auto
then have "(λn. f n $$ (i, j)) ⇢ lim (λn. f n $$ (i, j)) " using convergent_LIMSEQ_iff by auto
then show ?thesis using ij by auto
qed
from dim dim_A lim_A have lim_mat_A: "limit_mat f ?A dim" unfolding limit_mat_def by auto
have is_ub: "f n ≤⇩L ?A" for n
proof -
have "∀ m ≥ n. positive (f m - f n)" using lowner_le_transitive by auto
then have le: "∀ m ≥ n. f n ≤⇩L f m " unfolding lowner_le_def using dim
by (metis carrier_matD(1) carrier_matD(2))
have dimn: "f n ∈ carrier_mat dim dim" using dim by auto
then have limAf: "limit_mat (mat_seq_minus f (f n)) (?A - f n) dim" using minus_mat_limit lim_mat_A by auto
have " ∀m≥n. positive (f m - f n)" using lowner_le_transitive by auto
then have "∃k. ∀m≥k. positive (f m - f n)" by auto
then have posAf: "∃ k. ∀ m ≥ k. positive ((mat_seq_minus f (f n)) m)" unfolding mat_seq_minus_def by auto
from limAf posAf have "positive (?A - f n)" using pos_mat_lim_is_pos_aux by auto
then have "f n ≤⇩L mat dim dim (λ(i, j). lim (λn. f n $$ (i, j)))" unfolding lowner_le_def using dim by auto
then show ?thesis by auto
qed
have is_lub: "?A ≤⇩L M'" if ub: "∀n. f n ≤⇩L M'" for M'
proof -
have dim_M: "M' ∈ carrier_mat dim dim" using ub unfolding lowner_le_def using dim
by (metis carrier_matD(1) carrier_matD(2) carrier_mat_triv)
from ub have posAf: "∀ n. positive (minus_mat_seq M' f n)" unfolding minus_mat_seq_def lowner_le_def by auto
have limAf: "limit_mat (minus_mat_seq M' f) (M' - ?A) dim"
using mat_minus_limit dim_A lim_mat_A by auto
from posAf limAf have "positive (M' - ?A)" using pos_mat_lim_is_pos_aux by auto
then have "?A ≤⇩L M'" unfolding lowner_le_def using dim dim_A dim_M by auto
then show ?thesis by auto
qed
from is_ub is_lub show ?thesis unfolding lowner_is_lub_def by auto
qed
text ‹Lowner partial order is a complete partial order.›
lemma lowner_lub_exists: "∃M. lowner_is_lub M"
using lowner_lub_form by auto
lemma lowner_lub_unique: "∃!M. lowner_is_lub M"
proof (rule HOL.ex_ex1I)
show "∃M. lowner_is_lub M"
by (rule lowner_lub_exists)
next
fix M N
assume M: "lowner_is_lub M" and N: "lowner_is_lub N"
have Md: "M ∈ carrier_mat dim dim" using M by (rule lowner_is_lub_dim)
have Nd: "N ∈ carrier_mat dim dim" using N by (rule lowner_is_lub_dim)
have MN: "M ≤⇩L N" using M N by (simp add: lowner_is_lub_def)
have NM: "N ≤⇩L M" using M N by (simp add: lowner_is_lub_def)
show "M = N" using MN NM by (auto intro: lowner_le_antisym[OF Md Nd])
qed
definition lowner_lub :: "complex mat" where
"lowner_lub = (THE M. lowner_is_lub M)"
lemma lowner_lub_prop: "lowner_is_lub lowner_lub"
unfolding lowner_lub_def
apply (rule HOL.theI')
by (rule lowner_lub_unique)
lemma lowner_lub_is_limit:
"limit_mat f lowner_lub dim"
proof -
define A where "A = lowner_lub"
then have "A = (THE M. lowner_is_lub M)" using lowner_lub_def by auto
then have Af: "A = (mat dim dim (λ (i, j). (lim (λ n. (f n) $$ (i, j)))))"
using lowner_lub_form lowner_lub_unique by auto
show "limit_mat f A dim" unfolding Af limit_mat_def
apply (auto simp add: dim)
proof -
fix i j assume dims: "i < dim" "j < dim"
then have "convergent (λn. f n $$ (i, j))" using inc_partial_density_operator_converge by auto
then show "(λn. f n $$ (i, j)) ⇢ lim (λn. f n $$ (i, j))" using convergent_LIMSEQ_iff by auto
qed
qed
lemma lowner_lub_trace:
assumes "∀ n. trace (f n) ≤ x"
shows "trace lowner_lub ≤ x"
proof -
have "∀ n. trace (f n) ≥ 0" using positive_trace pdo unfolding partial_density_operator_def
using dim by blast
then have Re: "∀ n. Re (trace (f n)) ≥ 0 ∧ Im (trace (f n)) = 0" by auto
then have lex: "∀ n. Re (trace (f n)) ≤ Re x ∧ Im x = 0" using assms by auto
have "limit_mat f lowner_lub dim" using lowner_lub_is_limit by auto
then have conv: "(λn. trace (f n)) ⇢ trace lowner_lub" using mat_trace_limit by auto
then have "(λn. Re (trace (f n))) ⇢ Re (trace lowner_lub)"
by (simp add: tendsto_Re)
then have Rell: "Re (trace lowner_lub) ≤ Re x"
using lex Lim_bounded[of "(λn. Re (trace (f n)))" "Re (trace lowner_lub)" 0 "Re x"] by simp
from conv have "(λn. Im (trace (f n))) ⇢ Im (trace lowner_lub)"
by (simp add: tendsto_Im)
then have Imll: "Im (trace lowner_lub) = 0" using Re
by (simp add: Lim_bounded Lim_bounded2 dual_order.antisym)
from Rell Imll lex show ?thesis by simp
qed
lemma lowner_lub_is_positive:
shows "positive lowner_lub"
using lowner_lub_is_limit pos_mat_lim_is_pos pdo unfolding partial_density_operator_def by auto
end
subsection ‹Finite sum of matrices›
text ‹Add f in the interval [0, n)›
fun matrix_sum :: "nat ⇒ (nat ⇒ 'b::semiring_1 mat) ⇒ nat ⇒ 'b mat" where
"matrix_sum d f 0 = 0⇩m d d"
| "matrix_sum d f (Suc n) = f n + matrix_sum d f n"
definition matrix_inf_sum :: "nat ⇒ (nat ⇒ complex mat) ⇒ complex mat" where
"matrix_inf_sum d f = matrix_seq.lowner_lub (λn. matrix_sum d f n)"
lemma matrix_sum_dim:
fixes f :: "nat ⇒ 'b::semiring_1 mat"
shows "(⋀k. k < n ⟹ f k ∈ carrier_mat d d) ⟹ matrix_sum d f n ∈ carrier_mat d d"
proof (induct n)
case 0
show ?case by auto
next
case (Suc n)
then have "f n ∈ carrier_mat d d" by auto
then show ?case using Suc by auto
qed
lemma matrix_sum_cong:
fixes f :: "nat ⇒ 'b::semiring_1 mat"
shows "(⋀k. k < n ⟹ f k = f' k) ⟹ matrix_sum d f n = matrix_sum d f' n"
proof (induct n)
case 0
show ?case by auto
next
case (Suc n)
then show ?case unfolding matrix_sum.simps by auto
qed
lemma matrix_sum_add:
fixes f :: "nat ⇒ 'b::semiring_1 mat" and g :: "nat ⇒ 'b::semiring_1 mat" and h :: "nat ⇒ 'b::semiring_1 mat"
shows "(⋀k. k < n ⟹ f k ∈ carrier_mat d d) ⟹ (⋀k. k < n ⟹ g k ∈ carrier_mat d d) ⟹ (⋀k. k < n ⟹ h k ∈ carrier_mat d d) ⟹
(⋀k. k < n ⟹ f k = g k + h k) ⟹ matrix_sum d f n = matrix_sum d g n + matrix_sum d h n"
proof (induct n)
case 0
then show ?case by auto
next
case (Suc n)
then show ?case
proof -
have gh: "matrix_sum d g n ∈ carrier_mat d d ∧ matrix_sum d h n ∈ carrier_mat d d"
using matrix_sum_dim Suc(3, 4) by (simp add: matrix_sum_dim)
have nSuc: "n < Suc n" by auto
have sumf: "matrix_sum d f n = matrix_sum d g n + matrix_sum d h n" using Suc by auto
have "matrix_sum d f (Suc n) = matrix_sum d g (Suc n) + matrix_sum d h (Suc n)"
unfolding matrix_sum.simps Suc(5)[OF nSuc] sumf
apply (mat_assoc d) using gh Suc by auto
then show ?thesis by auto
qed
qed
lemma matrix_sum_smult:
fixes f :: "nat ⇒ 'b::semiring_1 mat"
shows "(⋀k. k < n ⟹ f k ∈ carrier_mat d d) ⟹
matrix_sum d (λ k. c ⋅⇩m f k) n = c ⋅⇩m matrix_sum d f n"
proof (induct n)
case 0
then show ?case by auto
next
case (Suc n)
then show ?case
apply auto
using add_smult_distrib_left_mat Suc matrix_sum_dim
by (metis lessI less_SucI)
qed
lemma matrix_sum_remove:
fixes f :: "nat ⇒ 'b::semiring_1 mat"
assumes j: "j < n"
and df: "(⋀k. k < n ⟹ f k ∈ carrier_mat d d)"
and f': "(⋀k. f' k = (if k = j then 0⇩m d d else f k))"
shows "matrix_sum d f n = f j + matrix_sum d f' n"
proof -
have df': "⋀k. k < n ⟹ f' k ∈ carrier_mat d d" using f' df by auto
have dsf: "k < n ⟹ matrix_sum d f k ∈ carrier_mat d d" for k using matrix_sum_dim[OF df] by auto
have dsf': "k < n ⟹ matrix_sum d f' k ∈ carrier_mat d d" for k using matrix_sum_dim[OF df'] by auto
have flj: "⋀k. k < j ⟹ f' k = f k" using j f' by auto
then have "matrix_sum d f j = matrix_sum d f' j" using matrix_sum_cong[of j f' f, OF flj] df df' j by auto
then have eqj: "matrix_sum d f (Suc j) = f j + matrix_sum d f' (Suc j)" unfolding matrix_sum.simps
by (subst (1) f', simp add: df dsf' j)
have lm: "(j + 1) + l ≤ n ⟹ matrix_sum d f ((j + 1) + l) = f j + matrix_sum d f' ((j + 1) + l)" for l
proof (induct l)
case 0
show ?case using j eqj by auto
next
case (Suc l) then have eq: "matrix_sum d f ((j + 1) + l) = f j + matrix_sum d f' ((j + 1) + l)" by auto
have s: "((j + 1) + Suc l) = Suc ((j + 1) + l)" by simp
have eqf': "f' (j + 1 + l) = f (j + 1 + l)" using f' Suc by auto
have dims: "f (j + 1 + l) ∈ carrier_mat d d" "f j ∈ carrier_mat d d" "matrix_sum d f' (j + 1 + l) ∈ carrier_mat d d" using df df' dsf' Suc by auto
show ?case apply (subst (1 2) s) unfolding matrix_sum.simps
apply (subst eq, subst eqf')
apply (mat_assoc d) using dims by auto
qed
have p: "(j + 1) + (n - j - 1) ≤ n" using j by auto
show ?thesis using lm[OF p] j by auto
qed
lemma matrix_sum_Suc_remove_head:
fixes f :: "nat ⇒ complex mat"
shows "(⋀k. k < n + 1 ⟹ f k ∈ carrier_mat d d) ⟹
matrix_sum d f (n + 1) = f 0 + matrix_sum d (λk. f (k + 1)) n"
proof (induct n)
case 0
then show ?case by auto
next
case (Suc n)
then have dSS: "⋀k. k < Suc (Suc n) ⟹ f k ∈ carrier_mat d d" by auto
have ds: "matrix_sum d (λk. f (k + 1)) n ∈ carrier_mat d d" using matrix_sum_dim[OF dSS, of "n" "λk. k + 1"] by auto
have "matrix_sum d f (Suc n + 1) = f (n + 1) + matrix_sum d f (n + 1)" by auto
also have "… = f (n + 1) + (f 0 + matrix_sum d (λk. f (k + 1)) n)" using Suc by auto
also have "… = f 0 + (f (n + 1) + matrix_sum d (λk. f (k + 1)) n)"
using ds apply (mat_assoc d) using dSS by auto
finally show ?case by auto
qed
lemma matrix_sum_positive:
fixes f :: "nat ⇒ complex mat"
shows "(⋀k. k < n ⟹ f k ∈ carrier_mat d d) ⟹ (⋀k. k < n ⟹ positive (f k))
⟹ positive (matrix_sum d f n)"
proof (induct n)
case 0
show ?case using positive_zero by auto
next
case (Suc n)
then have dfn: "f n ∈ carrier_mat d d" and psn: "positive (matrix_sum d f n)" and pn: "positive (f n)" and d: "k < n ⟹ f k ∈ carrier_mat d d" for k by auto
then have dsn: "matrix_sum d f n ∈ carrier_mat d d" using matrix_sum_dim by auto
show ?case unfolding matrix_sum.simps using positive_add[OF pn psn dfn dsn] by auto
qed
lemma matrix_sum_mult_right:
shows "(⋀k. k < n ⟹ f k ∈ carrier_mat d d) ⟹ A ∈ carrier_mat d d
⟹ matrix_sum d (λk. (f k) * A) n = matrix_sum d (λk. f k) n * A"
proof (induct n)
case 0
then show ?case by auto
next
case (Suc n)
then have "k < n ⟹ f k ∈ carrier_mat d d" and dfn: "f n ∈ carrier_mat d d" for k by auto
then have dsfn: "matrix_sum d f n ∈ carrier_mat d d" using matrix_sum_dim by auto
have "(f n + matrix_sum d f n) * A = f n * A + matrix_sum d f n * A"
apply (mat_assoc d) using Suc dsfn by auto
also have "… = f n * A + matrix_sum d (λk. f k * A) n" using Suc by auto
finally show ?case by auto
qed
lemma matrix_sum_add_distrib:
shows "(⋀k. k < n ⟹ f k ∈ carrier_mat d d) ⟹ (⋀k. k < n ⟹ g k ∈ carrier_mat d d)
⟹ matrix_sum d (λk. (f k) + (g k)) n = matrix_sum d f n + matrix_sum d g n"
proof (induct n)
case 0
then show ?case by auto
next
case (Suc n)
then have dfn: "f n ∈ carrier_mat d d" and dgn: "g n ∈ carrier_mat d d"
and dfk: "k < n ⟹ f k ∈ carrier_mat d d" and dgk: "k < n ⟹ g k ∈ carrier_mat d d"
and eq: "matrix_sum d (λk. f k + g k) n = matrix_sum d f n + matrix_sum d g n" for k by auto
have dsf: "matrix_sum d f n ∈ carrier_mat d d" using matrix_sum_dim dfk by auto
have dsg: "matrix_sum d g n ∈ carrier_mat d d" using matrix_sum_dim dgk by auto
show ?case unfolding matrix_sum.simps eq
using dfn dgn dsf dsg by (mat_assoc d)
qed
lemma matrix_sum_minus_distrib:
fixes f g :: "nat ⇒ complex mat"
shows "(⋀k. k < n ⟹ f k ∈ carrier_mat d d) ⟹ (⋀k. k < n ⟹ g k ∈ carrier_mat d d)
⟹ matrix_sum d (λk. (f k) - (g k)) n = matrix_sum d f n - matrix_sum d g n"
proof -
have eq: "-1 ⋅⇩m g k = - g k" for k by auto
assume dfk: "⋀k. k < n ⟹ f k ∈ carrier_mat d d" and dgk: "⋀k. k < n ⟹ (g k) ∈ carrier_mat d d"
then have "k < n ⟹ (f k) - (g k) = (f k) + (- (g k))" for k by auto
then have "matrix_sum d (λk. (f k) - (g k)) n = matrix_sum d (λk. (f k) + (- (g k))) n"
using matrix_sum_cong[of n "λk. (f k) - (g k)"] dfk dgk by auto
also have "… = matrix_sum d f n + matrix_sum d (λk. - (g k)) n"
using matrix_sum_add_distrib[of n "f"] dfk dgk by auto
also have "… = matrix_sum d f n - matrix_sum d g n"
apply (subgoal_tac "matrix_sum d (λk. - (g k)) n = - matrix_sum d g n", auto)
apply (subgoal_tac "- 1 ⋅⇩m matrix_sum d g n = - matrix_sum d g n")
by (simp add: matrix_sum_smult[of n g d "-1", OF dgk, simplified eq, simplified], auto)
finally show ?thesis .
qed
lemma matrix_sum_shift_Suc:
shows "(⋀k. k < (Suc n) ⟹ f k ∈ carrier_mat d d)
⟹ matrix_sum d f (Suc n) = f 0 + matrix_sum d (λk. f (Suc k)) n"
proof (induct n)
case 0
then show ?case by auto
next
case (Suc n)
have dfk: "k < Suc (Suc n) ⟹ f k ∈ carrier_mat d d" for k using Suc by auto
have dsSk: "k < Suc n ⟹ matrix_sum d (λk. f (Suc k)) n ∈ carrier_mat d d" for k using matrix_sum_dim[of _ "λk. f (Suc k)"] dfk by fastforce
have "matrix_sum d f (Suc (Suc n)) = f (Suc n) + matrix_sum d f (Suc n)" by auto
also have "… = f (Suc n) + f 0 + matrix_sum d (λk. f (Suc k)) n" using Suc dsSk assoc_add_mat[of "f (Suc n)" d d "f 0"] by fastforce
also have "… = f 0 + (f (Suc n) + matrix_sum d (λk. f (Suc k)) n)" apply (mat_assoc d) using dsSk dfk by auto
also have "… = f 0 + matrix_sum d (λk. f (Suc k)) (Suc n)" by auto
finally show ?case .
qed
lemma lowner_le_matrix_sum:
fixes f g :: "nat ⇒ complex mat"
shows "(⋀k. k < n ⟹ f k ∈ carrier_mat d d) ⟹ (⋀k. k < n ⟹ g k ∈ carrier_mat d d)
⟹ (⋀k. k < n ⟹ f k ≤⇩L g k)
⟹ matrix_sum d f n ≤⇩L matrix_sum d g n"
proof (induct n)
case 0
show ?case unfolding matrix_sum.simps using lowner_le_refl[of "0⇩m d d" d] by auto
next
case (Suc n)
then have dfn: "f n ∈ carrier_mat d d" and dgn: "g n ∈ carrier_mat d d" and le1: "f n ≤⇩L g n" by auto
then have le2: "matrix_sum d f n ≤⇩L matrix_sum d g n" using Suc by auto
have "k < n ⟹ f k ∈ carrier_mat d d" for k using Suc by auto
then have dsf: "matrix_sum d f n ∈ carrier_mat d d" using matrix_sum_dim by auto
have "k < n ⟹ g k ∈ carrier_mat d d" for k using Suc by auto
then have dsg: "matrix_sum d g n ∈ carrier_mat d d" using matrix_sum_dim by auto
show ?case unfolding matrix_sum.simps using lowner_le_add dfn dsf dgn dsg le1 le2 by auto
qed
lemma lowner_lub_add:
assumes "matrix_seq d f" "matrix_seq d g" "∀ n. trace (f n + g n) ≤ 1"
shows "matrix_seq.lowner_lub (λn. f n + g n) = matrix_seq.lowner_lub f + matrix_seq.lowner_lub g"
proof -
have msf: "matrix_seq.lowner_is_lub f (matrix_seq.lowner_lub f)" using assms(1) matrix_seq.lowner_lub_prop by auto
then have "limit_mat f (matrix_seq.lowner_lub f) d" using matrix_seq.lowner_lub_is_limit assms by auto
then have lim1: "∀i<d. ∀j<d. (λn. f n $$ (i, j)) ⇢ (matrix_seq.lowner_lub f) $$ (i, j)" using limit_mat_def assms by auto
have msg: "matrix_seq.lowner_is_lub g (matrix_seq.lowner_lub g)" using assms(2) matrix_seq.lowner_lub_prop by auto
then have "limit_mat g (matrix_seq.lowner_lub g) d" using matrix_seq.lowner_lub_is_limit assms by auto
then have lim2: "∀i<d. ∀j<d. (λn. g n $$ (i, j)) ⇢ (matrix_seq.lowner_lub g) $$ (i, j)" using limit_mat_def assms by auto
have "∀n. f n + g n ∈ carrier_mat d d" using assms unfolding matrix_seq_def by fastforce
moreover have "∀n. partial_density_operator (f n + g n)" using assms
unfolding matrix_seq_def partial_density_operator_def using positive_add by blast
moreover have "(f n + g n) ≤⇩L (f (Suc n) + g (Suc n))" for n
using assms
unfolding matrix_seq_def using lowner_le_add[of "f n" d "f (Suc n)" "g n" "g (Suc n)"] by auto
ultimately have msfg: "matrix_seq d (λn. f n + g n)" using assms unfolding matrix_seq_def by auto
then have mslfg: "matrix_seq.lowner_is_lub (λn. f n + g n) (matrix_seq.lowner_lub (λn. f n + g n))"
using matrix_seq.lowner_lub_prop by auto
then have "limit_mat (λn. f n + g n) (matrix_seq.lowner_lub (λn. f n + g n)) d" using matrix_seq.lowner_lub_is_limit msfg by auto
then have lim3: "∀i<d. ∀j<d. (λn. (f n + g n) $$ (i, j)) ⇢ (matrix_seq.lowner_lub (λn. f n + g n)) $$ (i, j)" using limit_mat_def assms by auto
have "∀ i<d. ∀ j<d. ∀ n. (f n + g n) $$ (i, j) = f n $$ (i, j) + g n $$ (i, j)" using assms unfolding matrix_seq_def
by (metis carrier_matD(1) carrier_matD(2) index_add_mat(1))
then have add: "∀i<d. ∀j<d. (λn. f n $$ (i, j) + g n $$ (i, j)) ⇢ (matrix_seq.lowner_lub (λn. f n + g n)) $$ (i, j)" using lim3 by auto
have "matrix_seq.lowner_lub f $$ (i, j) + matrix_seq.lowner_lub g $$ (i, j) = matrix_seq.lowner_lub (λn. f n + g n) $$ (i, j)"
if i: "i < d" and j: "j < d" for i j
proof -
have "(λn. f n $$ (i, j)) ⇢ matrix_seq.lowner_lub f $$ (i, j)" using lim1 i j by auto
moreover have "(λn. g n $$ (i, j)) ⇢ matrix_seq.lowner_lub g $$ (i, j)" using lim2 i j by auto
ultimately have "(λn. f n $$ (i, j) + g n $$ (i, j)) ⇢ matrix_seq.lowner_lub f $$ (i, j) + matrix_seq.lowner_lub g $$ (i, j)"
using tendsto_add[of "λn. f n $$ (i, j)" "matrix_seq.lowner_lub f $$ (i, j)" sequentially "λn. g n $$ (i, j)" "matrix_seq.lowner_lub g $$ (i, j)"] by auto
moreover have "(λn. f n $$ (i, j) + g n $$ (i, j)) ⇢ matrix_seq.lowner_lub (λn. f n + g n) $$ (i, j)" using add i j by auto
ultimately show ?thesis using LIMSEQ_unique by auto
qed
moreover have "matrix_seq.lowner_lub f ∈ carrier_mat d d" using matrix_seq.lowner_is_lub_dim assms(1) msf unfolding matrix_seq_def by auto
moreover have "matrix_seq.lowner_lub g ∈ carrier_mat d d" using matrix_seq.lowner_is_lub_dim assms(2) msg unfolding matrix_seq_def by auto
moreover have "matrix_seq.lowner_lub (λn. f n + g n) ∈ carrier_mat d d" using matrix_seq.lowner_is_lub_dim msfg mslfg unfolding matrix_seq_def by auto
ultimately show ?thesis unfolding matrix_seq_def using mat_eq_iff by auto
qed
lemma lowner_lub_scale:
fixes c :: real
assumes "matrix_seq d f" "∀ n. trace (c ⋅⇩m f n) ≤ 1" "c≥0"
shows "matrix_seq.lowner_lub (λn. c ⋅⇩m f n) = c ⋅⇩m matrix_seq.lowner_lub f"
proof -
have msf: "matrix_seq.lowner_is_lub f (matrix_seq.lowner_lub f)"
using assms(1) matrix_seq.lowner_lub_prop by auto
then have "limit_mat f (matrix_seq.lowner_lub f) d"
using matrix_seq.lowner_lub_is_limit assms by auto
then have lim1: "∀i<d. ∀j<d. (λn. f n $$ (i, j)) ⇢ (matrix_seq.lowner_lub f) $$ (i, j)"
using limit_mat_def assms by auto
have dimcf: "∀n. c ⋅⇩m f n ∈ carrier_mat d d" using assms unfolding matrix_seq_def by fastforce
moreover have "∀n. partial_density_operator (c ⋅⇩m f n)" using assms
unfolding matrix_seq_def partial_density_operator_def using positive_scale by blast
moreover have "∀n. c ⋅⇩m f n ≤⇩L c ⋅⇩m f (Suc n)" using lowner_le_smult assms(1,3)
unfolding matrix_seq_def partial_density_operator_def by blast
ultimately have mscf: "matrix_seq d (λn. c ⋅⇩m f n)" unfolding matrix_seq_def by auto
then have mslfg: "matrix_seq.lowner_is_lub (λn. c ⋅⇩m f n) (matrix_seq.lowner_lub (λn. c ⋅⇩m f n))"
using matrix_seq.lowner_lub_prop by auto
then have "limit_mat (λn. c ⋅⇩m f n) (matrix_seq.lowner_lub (λn. c ⋅⇩m f n)) d"
using matrix_seq.lowner_lub_is_limit mscf by auto
then have lim3: "∀i<d. ∀j<d. (λn. (c ⋅⇩m f n) $$ (i, j)) ⇢ (matrix_seq.lowner_lub (λn. c ⋅⇩m f n)) $$ (i, j)"
using limit_mat_def assms by auto
from mslfg mscf have dleft: "matrix_seq.lowner_lub (λn. c ⋅⇩m f n) ∈ carrier_mat d d"
using matrix_seq.lowner_is_lub_dim by auto
have dllf: "matrix_seq.lowner_lub f ∈ carrier_mat d d"
using matrix_seq.lowner_is_lub_dim assms(1) msf unfolding matrix_seq_def by auto
then have dright: "c ⋅⇩m matrix_seq.lowner_lub f ∈ carrier_mat d d" using index_smult_mat(2,3) by auto
have "∀ i<d. ∀ j<d. ∀ n. (c ⋅⇩m f n) $$ (i, j) = c * f n $$ (i, j)"
using assms(1) unfolding matrix_seq_def using index_smult_mat(1)
by (metis carrier_matD(1-2))
then have smult: "∀i<d. ∀j<d. (λn. c * f n $$ (i, j)) ⇢ (matrix_seq.lowner_lub (λn. c ⋅⇩m f n)) $$ (i, j)"
using lim3 by auto
have ij: "(c ⋅⇩m matrix_seq.lowner_lub f) $$ (i, j) = (matrix_seq.lowner_lub (λn. c ⋅⇩m f n)) $$ (i, j)"
if i: "i < d" and j: "j < d" for i j
proof -
have "(λn. f n $$ (i, j)) ⇢ matrix_seq.lowner_lub f $$ (i, j)" using lim1 i j by auto
moreover have "∀i<d. ∀j<d.(c ⋅⇩m matrix_seq.lowner_lub f) $$ (i, j) = c * matrix_seq.lowner_lub f $$ (i, j)"
using index_smult_mat dllf by fastforce
ultimately have "∀i<d. ∀j<d. (λn. c * f n $$ (i, j)) ⇢(c ⋅⇩m matrix_seq.lowner_lub f) $$ (i, j)"
using tendsto_intros(18)[of "λn. c" "c" sequentially "λn. f n $$ (i, j)" "matrix_seq.lowner_lub f $$ (i, j)"] i j
by (simp add: lim1 tendsto_mult_left)
then show ?thesis using smult i j LIMSEQ_unique by metis
qed
from dleft dright ij show ?thesis
using mat_eq_iff[of "matrix_seq.lowner_lub (λn. c ⋅⇩m f n)" "c ⋅⇩m matrix_seq.lowner_lub f"]
by (metis (mono_tags) carrier_matD(1) carrier_matD(2))
qed
lemma trace_matrix_sum_linear:
fixes f :: "nat ⇒ complex mat"
shows "(⋀k. k < n ⟹ f k ∈ carrier_mat d d) ⟹ trace (matrix_sum d f n) = sum (λk. trace (f k)) {0..<n}"
proof (induct n)
case 0
show ?case by auto
next
case (Suc n)
then have "⋀k. k < n ⟹ f k ∈ carrier_mat d d" by auto
then have ds: "matrix_sum d f n ∈ carrier_mat d d" using matrix_sum_dim by auto
have "trace (matrix_sum d f (Suc n)) = trace (f n) + trace (matrix_sum d f n)"
unfolding matrix_sum.simps apply (mat_assoc d) using ds Suc by auto
also have "… = sum (trace ∘ f) {0..<n} + (trace ∘ f) n" using Suc by auto
also have "… = sum (trace ∘ f) {0..<Suc n}" by auto
finally show ?case by auto
qed
lemma matrix_sum_distrib_left:
fixes f :: "nat ⇒ complex mat"
shows "P ∈ carrier_mat d d ⟹ (⋀k. k < n ⟹ f k ∈ carrier_mat d d) ⟹ matrix_sum d (λk. P * (f k)) n = P * (matrix_sum d f n)"
proof (induct n)
case 0
show ?case unfolding matrix_sum.simps using 0 by auto
next
case (Suc n)
then have "⋀k. k < n ⟹ f k ∈ carrier_mat d d" by auto
then have ds: "matrix_sum d f n ∈ carrier_mat d d" using matrix_sum_dim by auto
then have dPf: "⋀k. k < n ⟹ P * f k ∈ carrier_mat d d" using Suc by auto
then have "matrix_sum d (λk. P * f k) n ∈ carrier_mat d d" using matrix_sum_dim[OF dPf] by auto
have "matrix_sum d (λk. P * f k) (Suc n) = P * f n + matrix_sum d (λk. P * f k) n " unfolding matrix_sum.simps using Suc(2) by auto
also have "… = P * f n + P * matrix_sum d f n" using Suc by auto
also have "… = P * (f n + matrix_sum d f n)" apply (mat_assoc d) using ds dPf Suc by auto
finally show "matrix_sum d (λk. P * f k) (Suc n) = P * (matrix_sum d f (Suc n))" by auto
qed
subsection ‹Measurement›
definition measurement :: "nat ⇒ nat ⇒ (nat ⇒ complex mat) ⇒ bool" where
"measurement d n M ⟷ (∀j < n. M j ∈ carrier_mat d d)
∧ matrix_sum d (λj. (adjoint (M j)) * M j) n = 1⇩m d"
lemma measurement_dim:
assumes "measurement d n M"
shows "⋀k. k < n ⟹ (M k) ∈ carrier_mat d d"
using assms unfolding measurement_def by auto
lemma measurement_id2:
assumes "measurement d 2 M"
shows "adjoint (M 0) * M 0 + adjoint (M 1) * M 1 = 1⇩m d"
proof -
have ssz: "(Suc (Suc 0)) = 2" by auto
have "M 0 ∈ carrier_mat d d" "M 1 ∈ carrier_mat d d" using assms measurement_def by auto
then have "adjoint (M 0) * M 0 + adjoint (M 1) * M 1 = matrix_sum d (λj. (adjoint (M j)) * M j) (Suc (Suc 0)) "
by auto
also have "… = matrix_sum d (λj. (adjoint (M j)) * M j) (2::nat)" by (subst ssz, auto)
also have "… = 1⇩m d" using measurement_def[of d 2 M] assms by auto
finally show ?thesis by auto
qed
text ‹Result of measurement on $\rho$ by matrix M›
definition measurement_res :: "complex mat ⇒ complex mat ⇒ complex mat" where
"measurement_res M ρ = M * ρ * adjoint M"
lemma add_positive_le_reduce1:
assumes dA: "A ∈ carrier_mat n n" and dB: "B ∈ carrier_mat n n" and dC: "C ∈ carrier_mat n n"
and pB: "positive B" and le: "A + B ≤⇩L C"
shows "A ≤⇩L C"
unfolding lowner_le_def positive_def
proof (auto simp add: carrier_matD[OF dA] carrier_matD[OF dC] simp del: less_eq_complex_def)
have eq: "C - (A + B) = (C - A + (-B))" using dA dB dC by auto
have "positive (C - (A + B))" using le lowner_le_def dA dB dC by auto
with eq have p: "positive (C - A + (-B))" by auto
fix v :: "complex vec" assume " n = dim_vec v"
then have dv: "v ∈ carrier_vec n" by auto
have ge: "inner_prod v (B *⇩v v) ≥ 0" using pB dv dB positive_def by auto
have "0 ≤ inner_prod v ((C - A + (-B)) *⇩v v) " using p positive_def dv dA dB dC by auto
also have "… = inner_prod v ((C - A)*⇩v v + (-B) *⇩v v) "
using dv dA dB dC add_mult_distrib_mat_vec[OF minus_carrier_mat[OF dA]] by auto
also have "… = inner_prod v ((C - A) *⇩v v) + inner_prod v ((-B) *⇩v v)"
apply (subst inner_prod_distrib_right)
by (rule dv, auto simp add: mult_mat_vec_carrier[OF minus_carrier_mat[OF dA]] mult_mat_vec_carrier[OF uminus_carrier_mat[OF dB]] dv)
also have "… = inner_prod v ((C - A) *⇩v v) - inner_prod v (B *⇩v v)" using dB dv by auto
also have "… ≤ inner_prod v ((C - A) *⇩v v)" using ge by auto
finally show "0 ≤ inner_prod v ((C - A) *⇩v v)".
qed
lemma add_positive_le_reduce2:
assumes dA: "A ∈ carrier_mat n n" and dB: "B ∈ carrier_mat n n" and dC: "C ∈ carrier_mat n n"
and pB: "positive B" and le: "B + A ≤⇩L C"
shows "A ≤⇩L C"
apply (subgoal_tac "B + A = A + B") using add_positive_le_reduce1[of A n B C] assms by auto
lemma measurement_le_one_mat:
assumes "measurement d n f"
shows "⋀j. j < n ⟹ adjoint (f j) * f j ≤⇩L 1⇩m d"
proof -
fix j assume j: "j < n"
define M where "M = adjoint (f j) * f j"
have df: "k < n ⟹ f k ∈ carrier_mat d d" for k using assms measurement_dim by auto
have daf: "k < n ⟹ adjoint (f k) * f k ∈ carrier_mat d d" for k
proof -
assume "k < n"
then have "f k ∈ carrier_mat d d" "adjoint (f k) ∈ carrier_mat d d" using df adjoint_dim by auto
then show "adjoint (f k) * f k ∈ carrier_mat d d" by auto
qed
have pafj: "k < n ⟹ positive (adjoint (f k) * (f k)) " for k
apply (subst (2) adjoint_adjoint[of "f k", symmetric])
by (metis adjoint_adjoint daf positive_if_decomp)
define f' where "⋀k. f' k = (if k = j then 0⇩m d d else adjoint (f k) * f k)"
have pf': "k < n ⟹ positive (f' k)" for k unfolding f'_def using positive_zero pafj j by auto
have df': "k < n ⟹ f' k ∈ carrier_mat d d" for k using daf j zero_carrier_mat f'_def by auto
then have dsf': "matrix_sum d f' n ∈ carrier_mat d d" using matrix_sum_dim[of n f' d] by auto
have psf': "positive (matrix_sum d f' n)" using matrix_sum_positive pafj df' pf' by auto
have "M + matrix_sum d f' n = matrix_sum d (λk. adjoint (f k) * f k) n"
using matrix_sum_remove[OF j , of "(λk. adjoint (f k) * f k)", OF daf, of f'] f'_def unfolding M_def by auto
also have "… = 1⇩m d" using measurement_def assms by auto
finally have "M + matrix_sum d f' n = 1⇩m d".
moreover have "1⇩m d ≤⇩L 1⇩m d" using lowner_le_refl[of _ d] by auto
ultimately have "(M + matrix_sum d f' n) ≤⇩L 1⇩m d" by auto
then show "M ≤⇩L 1⇩m d" unfolding M_def using add_positive_le_reduce1[OF _ dsf' one_carrier_mat psf'] daf j by auto
qed
lemma pdo_close_under_measurement:
fixes M ρ :: "complex mat"
assumes dM: "M ∈ carrier_mat n n" and dr: "ρ ∈ carrier_mat n n"
and pdor: "partial_density_operator ρ"
and le: "adjoint M * M ≤⇩L 1⇩m n"
shows "partial_density_operator (M * ρ * adjoint M)"
unfolding partial_density_operator_def
proof
show "positive (M * ρ * adjoint M)"
using positive_close_under_left_right_mult_adjoint[OF dM dr] pdor partial_density_operator_def by auto
next
have daM: "adjoint M ∈ carrier_mat n n" using dM by auto
then have daMM: "adjoint M * M ∈ carrier_mat n n" using dM by auto
have "trace (M * ρ * adjoint M) = trace (adjoint M * M * ρ)"
using dM dr by (mat_assoc n)
also have "… ≤ trace (1⇩m n * ρ)"
using lowner_le_trace[where ?B = "1⇩m n" and ?A = "adjoint M * M", OF daMM one_carrier_mat] le dr pdor by auto
also have "… = trace ρ" using dr by auto
also have "… ≤ 1" using pdor partial_density_operator_def by auto
finally show "trace (M * ρ * adjoint M) ≤ 1" by auto
qed
lemma trace_measurement:
assumes m: "measurement d n M" and dA: "A ∈ carrier_mat d d"
shows "trace (matrix_sum d (λk. (M k) * A * adjoint (M k)) n) = trace A"
proof -
have dMk: "k < n ⟹ (M k) ∈ carrier_mat d d" for k using m unfolding measurement_def by auto
then have daMk: "k < n ⟹ adjoint (M k) ∈ carrier_mat d d" for k using m adjoint_dim unfolding measurement_def by auto
have d1: "k < n ⟹ M k * A * adjoint (M k) ∈ carrier_mat d d"for k using dMk daMk dA by fastforce
then have ds1: "k < n ⟹ matrix_sum d (λk. M k * A * adjoint (M k)) k ∈ carrier_mat d d" for k
using matrix_sum_dim[of k "λk. M k * A * adjoint (M k)" d] by auto
have d2: "k < n ⟹ adjoint (M k) *M k * A ∈ carrier_mat d d" for k using daMk dMk dA by fastforce
then have ds2: "k < n ⟹ matrix_sum d (λk. adjoint (M k) *M k * A) k ∈ carrier_mat d d" for k
using matrix_sum_dim[of k "λk. adjoint (M k) *M k * A" d] by auto
have daMMk: "k < n ⟹ adjoint (M k) * M k ∈ carrier_mat d d" for k using dMk by fastforce
have "k ≤ n ⟹ trace (matrix_sum d (λk. (M k) * A * adjoint (M k)) k) = trace (matrix_sum d (λk. adjoint (M k) * (M k) * A) k)" for k
proof (induct k)
case 0
then show ?case by auto
next
case (Suc k)
then have k: "k < n" by auto
have "trace (M k * A * adjoint (M k)) = trace (adjoint (M k) * M k * A)"
using dA apply (mat_assoc d) using dMk k by auto
then show ?case unfolding matrix_sum.simps using ds1 ds2 d1 d2 k Suc daMk dMk dA
by (subst trace_add_linear[of _ d], auto)+
qed
then have "trace (matrix_sum d (λk. (M k) * A * adjoint (M k)) n) = trace (matrix_sum d (λk. adjoint (M k) * (M k) * A) n)" by auto
also have "… = trace (matrix_sum d (λk. adjoint (M k) * (M k)) n * A)" using matrix_sum_mult_right[OF daMMk, of n id A] dA by auto
also have "… = trace A" using m dA unfolding measurement_def by auto
finally show ?thesis by auto
qed
lemma mat_inc_seq_positive_transform:
assumes dfn: "⋀n. f n ∈ carrier_mat d d"
and inc: "⋀n. f n ≤⇩L f (Suc n)"
shows "⋀n. f n - f 0 ∈ carrier_mat d d" and "⋀n. (f n - f 0) ≤⇩L (f (Suc n) - f 0)"
proof -
show "⋀n. f n - f 0 ∈ carrier_mat d d" using dfn by fastforce
have "f 0 ≤⇩L f 0" using lowner_le_refl[of "f 0" d] dfn by auto
then show "(f n - f 0) ≤⇩L (f (Suc n) - f 0)" for n
using lowner_le_minus[of "f n" d "f (Suc n)" "f 0" "f 0"] dfn inc by fastforce
qed
lemma mat_inc_seq_lub:
assumes dfn: "⋀n. f n ∈ carrier_mat d d"
and inc: "⋀n. f n ≤⇩L f (Suc n)"
and ub: "⋀n. f n ≤⇩L A"
shows "∃B. lowner_is_lub f B ∧ limit_mat f B d"
proof -
have dmfn0: "⋀n. f n - f 0 ∈ carrier_mat d d" and incm0: "⋀n. (f n - f 0) ≤⇩L (f (Suc n) - f 0)"
using mat_inc_seq_positive_transform[OF dfn, of id] assms by auto
define c where "c = 1 / (trace (A - f 0) + 1)"
have "f 0 ≤⇩L A" using ub by auto
then have dA: "A ∈ carrier_mat d d" using ub unfolding lowner_le_def using dfn[of 0] by fastforce
then have dAmf0: "A - f 0 ∈ carrier_mat d d" using dfn[of 0] by auto
have "positive (A - f 0)" using ub lowner_le_def by auto
then have tgeq0: "trace (A - f 0) ≥ 0" using positive_trace dAmf0 by auto
then have "trace (A - f 0) + 1 > 0" by auto
then have gtc: "c > 0" unfolding c_def using complex_is_Real_iff by auto
then have gtci: "(1 / c) > 0" using complex_is_Real_iff by auto
have "trace (c ⋅⇩m (A - f 0)) = c * trace (A - f 0)"
using trace_smult dAmf0 by auto
also have "… = (1 / (trace (A - f 0) + 1)) * trace (A - f 0)" unfolding c_def by auto
also have "… < 1" using tgeq0 by (simp add: complex_is_Real_iff)
finally have lt1: "trace (c ⋅⇩m (A - f 0)) < 1".
have le0: "- f 0 ≤⇩L - f 0" using lowner_le_refl[of "- f 0" d] dfn by auto
have dmf0: "- f 0 ∈ carrier_mat d d" using dfn by auto
have mf0smcle: "(c ⋅⇩m (X - f 0)) ≤⇩L (c ⋅⇩m (Y - f 0))" if "X ≤⇩L Y" and "X ∈ carrier_mat d d" and "Y ∈ carrier_mat d d" for X Y
proof -
have "(X - f 0) ≤⇩L (Y - f 0)"
using lowner_le_minus[of "X" d "Y" "f 0" "f 0"] that dfn lowner_le_refl by auto
then show ?thesis using lowner_le_smultc[of c "(X - f 0)" "Y - f 0" d] using that dfn gtc by fastforce
qed
have "(c ⋅⇩m (f n - f 0)) ≤⇩L (c ⋅⇩m (A - f 0))" for n
using mf0smcle ub dfn dA by auto
then have "trace (c ⋅⇩m (f n - f 0)) ≤ trace (c ⋅⇩m (A - f 0))" for n
using lowner_le_imp_trace_le[of "c ⋅⇩m (f n - f 0)" d] dmfn0 dAmf0 by auto
then have trlt1: "trace (c ⋅⇩m (f n - f 0)) < 1" for n using lt1 by fastforce
have "f 0 ≤⇩L f n" for n
proof (induct n)
case 0
then show ?case using dfn lowner_le_refl by auto
next
case (Suc n)
then show ?case using dfn lowner_le_trans[of "f 0" d "f n"] inc by auto
qed
then have "positive (f n - f 0)" for n using lowner_le_def by auto
then have p: "positive (c ⋅⇩m (f n - f 0))" for n
by (intro positive_smult, insert gtc dmfn0, auto)
have inc': "c ⋅⇩m (f n - f 0) ≤⇩L c ⋅⇩m (f (Suc n) - f 0)" for n
using incm0 lowner_le_smultc[of c "f n - f 0"] gtc dmfn0 by fastforce
define g where "g n = c ⋅⇩m (f n - f 0)" for n
then have "positive (g n)" and "trace (g n) < 1" and "(g n) ≤⇩L (g (Suc n))" and dgn: "(g n) ∈ carrier_mat d d" for n
unfolding g_def using p trlt1 inc' dmfn0 by auto
then have ms: "matrix_seq d g" unfolding matrix_seq_def partial_density_operator_def by fastforce
then have uniM: "∃!M. matrix_seq.lowner_is_lub g M" using matrix_seq.lowner_lub_unique by auto
then obtain M where M: "matrix_seq.lowner_is_lub g M" by auto
then have leg: "g n ≤⇩L M" and lubg: "⋀M'. (∀n. g n ≤⇩L M') ⟶ M ≤⇩L M'" for n
unfolding matrix_seq.lowner_is_lub_def[OF ms] by auto
have "M = matrix_seq.lowner_lub g"
using matrix_seq.lowner_lub_def[OF ms] M uniM theI_unique[of "matrix_seq.lowner_is_lub g"] by auto
then have limg: "limit_mat g M d" using M matrix_seq.lowner_lub_is_limit[OF ms] by auto
then have dM: "M ∈ carrier_mat d d" unfolding limit_mat_def by auto
define B where "B = f 0 + (1 / c) ⋅⇩m M"
have eqinv: "f 0 + (1 / c) ⋅⇩m (c ⋅⇩m (X - f 0)) = X" if "X ∈ carrier_mat d d" for X
proof -
have "f 0 + (1 / c) ⋅⇩m (c ⋅⇩m (X - f 0)) = f 0 + (1 / c * c) ⋅⇩m (X - f 0)"
apply (subgoal_tac "(1 / c) ⋅⇩m (c ⋅⇩m (X - f 0)) = (1 / c * c) ⋅⇩m (X - f 0)", simp)
using smult_smult_mat dfn that by auto
also have "… = f 0 + 1 ⋅⇩m (X - f 0)" using gtc by auto
also have "… = f 0 + (X - f 0)" by auto
also have "… = (- f 0) + f 0 + X" apply (mat_assoc d) using that dfn by auto
also have "… = 0⇩m d d + X" using dfn uminus_l_inv_mat[of "f 0" d d] by fastforce
also have "… = X" using that by auto
finally show ?thesis by auto
qed
have "limit_mat (λn. (1 / c) ⋅⇩m g n) ((1 / c) ⋅⇩m M) d" using limit_mat_scale[OF limg] gtci by auto
then have "limit_mat (λn. f 0 + (1 / c) ⋅⇩m g n) (f 0 + (1 / c) ⋅⇩m M ) d"
using mat_add_limit[of "f 0"] limg dfn unfolding mat_add_seq_def by auto
then have limf: "limit_mat f B d" using eqinv[OF dfn] unfolding B_def g_def by auto
have f0acmcile: "(f 0 + (1 / c) ⋅⇩m X) ≤⇩L (f 0 + (1 / c) ⋅⇩m Y )" if "X ≤⇩L Y" and "X ∈ carrier_mat d d" and "Y ∈ carrier_mat d d" for X Y
proof -
have "((1 / c) ⋅⇩m X) ≤⇩L ((1 / c) ⋅⇩m Y)"
using lowner_le_smultc[of "1/c"] that gtci by fastforce
then show "(f 0 + (1 / c) ⋅⇩m X) ≤⇩L (f 0 + (1 / c) ⋅⇩m Y)"
using lowner_le_add[of _ d _ "(1 / c) ⋅⇩m X" "(1 / c) ⋅⇩m Y"]
that gtci dfn lowner_le_refl[of "f 0", OF dfn] by fastforce
qed
have "(f 0 + (1 / c) ⋅⇩m g n) ≤⇩L (f 0 + (1 / c) ⋅⇩m M )" for n
using f0acmcile[OF leg dgn dM] by auto
then have lubf: "f n ≤⇩L B" for n using eqinv[OF dfn] g_def B_def by auto
{
fix B' assume asm: "∀n. f n ≤⇩L B'"
then have "f 0 ≤⇩L B'" by auto
then have dB': "B' ∈ carrier_mat d d" unfolding lowner_le_def using dfn[of 0] by auto
have "f n ≤⇩L B'" for n using asm by auto
then have "(c ⋅⇩m (f n - f 0)) ≤⇩L (c ⋅⇩m (B' - f 0))" for n
using mf0smcle[of "f n" B'] dfn dB' by auto
then have "g n ≤⇩L (c ⋅⇩m (B' - f 0))" for n using g_def by auto
then have "M ≤⇩L (c ⋅⇩m (B' - f 0))" using lubg by auto
then have "(f 0 + (1 / c) ⋅⇩m M) ≤⇩L (f 0 + (1 / c) ⋅⇩m (c ⋅⇩m (B' - f 0)))"
using f0acmcile[of "M" "(c ⋅⇩m (B' - f 0))", OF _ dM] using dB' dfn by fastforce
then have "B ≤⇩L B'" unfolding B_def using eqinv[OF dB'] by auto
}
with limf lubf have "((∀n. f n ≤⇩L B) ∧ (∀M'. (∀n. f n ≤⇩L M') ⟶ B ≤⇩L M')) ∧ limit_mat f B d" by auto
then show ?thesis unfolding lowner_is_lub_def by auto
qed
end
Theory Quantum_Program
section ‹Quantum programs›
theory Quantum_Program
imports Matrix_Limit
begin
subsection ‹Syntax›
text ‹Datatype for quantum programs›
datatype com =
SKIP
| Utrans "complex mat"
| Seq com com ("_;;/ _" [60, 61] 60)
| Measure nat "nat ⇒ complex mat" "com list"
| While "nat ⇒ complex mat" com
text ‹A state corresponds to the density operator›
type_synonym state = "complex mat"
text ‹List of dimensions of quantum states›
locale state_sig =
fixes dims :: "nat list"
begin
definition d :: nat where
"d = prod_list dims"
text ‹Wellformedness of commands›
fun well_com :: "com ⇒ bool" where
"well_com SKIP = True"
| "well_com (Utrans U) = (U ∈ carrier_mat d d ∧ unitary U)"
| "well_com (Seq S1 S2) = (well_com S1 ∧ well_com S2)"
| "well_com (Measure n M S) =
(measurement d n M ∧ length S = n ∧ list_all well_com S)"
| "well_com (While M S) =
(measurement d 2 M ∧ well_com S)"
subsection ‹Denotational semantics›
text ‹Denotation of going through the while loop n times›
fun denote_while_n_iter :: "complex mat ⇒ complex mat ⇒ (state ⇒ state) ⇒ nat ⇒ state ⇒ state" where
"denote_while_n_iter M0 M1 DS 0 ρ = ρ"
| "denote_while_n_iter M0 M1 DS (Suc n) ρ = denote_while_n_iter M0 M1 DS n (DS (M1 * ρ * adjoint M1))"
fun denote_while_n :: "complex mat ⇒ complex mat ⇒ (state ⇒ state) ⇒ nat ⇒ state ⇒ state" where
"denote_while_n M0 M1 DS n ρ = M0 * denote_while_n_iter M0 M1 DS n ρ * adjoint M0"
fun denote_while_n_comp :: "complex mat ⇒ complex mat ⇒ (state ⇒ state) ⇒ nat ⇒ state ⇒ state" where
"denote_while_n_comp M0 M1 DS n ρ = M1 * denote_while_n_iter M0 M1 DS n ρ * adjoint M1"
lemma denote_while_n_iter_assoc:
"denote_while_n_iter M0 M1 DS (Suc n) ρ = DS (M1 * (denote_while_n_iter M0 M1 DS n ρ) * adjoint M1)"
proof (induct n arbitrary: ρ)
case 0
show ?case by auto
next
case (Suc n)
show ?case
apply (subst denote_while_n_iter.simps)
apply (subst Suc, auto)
done
qed
lemma denote_while_n_iter_dim:
"ρ ∈ carrier_mat m m ⟹ partial_density_operator ρ ⟹ M1 ∈ carrier_mat m m ⟹ adjoint M1 * M1 ≤⇩L 1⇩m m
⟹ (⋀ρ. ρ ∈ carrier_mat m m ⟹ partial_density_operator ρ ⟹ DS ρ ∈ carrier_mat m m ∧ partial_density_operator (DS ρ))
⟹ denote_while_n_iter M0 M1 DS n ρ ∈ carrier_mat m m ∧ partial_density_operator (denote_while_n_iter M0 M1 DS n ρ)"
proof (induct n arbitrary: ρ)
case 0
then show ?case unfolding denote_while_n_iter.simps by auto
next
case (Suc n)
then have dr: "ρ ∈ carrier_mat m m" and dM1: "M1 ∈ carrier_mat m m" by auto
have dMr: "M1 * ρ * adjoint M1 ∈ carrier_mat m m" using dr dM1 by fastforce
have pdoMr: "partial_density_operator (M1 * ρ * adjoint M1)" using pdo_close_under_measurement Suc by auto
from Suc dMr pdoMr have d: "DS (M1 * ρ * adjoint M1) ∈ carrier_mat m m" and "partial_density_operator (DS (M1 * ρ * adjoint M1))" by auto
then show ?case unfolding denote_while_n_iter.simps
using Suc by auto
qed
lemma pdo_denote_while_n_iter:
"ρ ∈ carrier_mat m m ⟹ partial_density_operator ρ ⟹ M1 ∈ carrier_mat m m ⟹ adjoint M1 * M1 ≤⇩L 1⇩m m
⟹ (⋀ρ. ρ ∈ carrier_mat m m ∧ partial_density_operator ρ ⟹ partial_density_operator (DS ρ))
⟹ (⋀ρ. ρ ∈ carrier_mat m m ∧ partial_density_operator ρ ⟹ DS ρ ∈ carrier_mat m m)
⟹ partial_density_operator (denote_while_n_iter M0 M1 DS n ρ)"
proof (induct n arbitrary: ρ)
case 0
then show ?case unfolding denote_while_n_iter.simps by auto
next
case (Suc n)
have "partial_density_operator (M1 * ρ * adjoint M1)" using Suc pdo_close_under_measurement by auto
moreover have "M1 * ρ * adjoint M1 ∈ carrier_mat m m" using Suc by auto
ultimately have p: "partial_density_operator (DS (M1 * ρ * adjoint M1))" and d: "DS (M1 * ρ * adjoint M1) ∈ carrier_mat m m "using Suc by auto
show ?case unfolding denote_while_n_iter.simps using Suc(1)[OF d p Suc(4) Suc(5)] Suc by auto
qed
text ‹Denotation of while is simply the infinite sum of denote\_while\_n›
definition denote_while :: "complex mat ⇒ complex mat ⇒ (state ⇒ state) ⇒ state ⇒ state" where
"denote_while M0 M1 DS ρ = matrix_inf_sum d (λn. denote_while_n M0 M1 DS n ρ)"
lemma denote_while_n_dim:
assumes "ρ ∈ carrier_mat d d"
"M0 ∈ carrier_mat d d"
"M1 ∈ carrier_mat d d"
"partial_density_operator ρ"
"⋀ρ'. ρ' ∈ carrier_mat d d ⟹ partial_density_operator ρ' ⟹ positive (DS ρ') ∧ trace (DS ρ') ≤ trace ρ' ∧ DS ρ' ∈ carrier_mat d d"
shows "denote_while_n M0 M1 DS n ρ ∈ carrier_mat d d"
proof (induction n arbitrary: ρ)
case 0
then show ?case
proof -
have "M0 * ρ * adjoint M0 ∈ carrier_mat d d"
using assms assoc_mult_mat by auto
then show ?thesis by auto
qed
next
case (Suc n)
then show ?case
proof -
have "denote_while_n M0 M1 DS n (DS (M1 * ρ * adjoint M1)) ∈ carrier_mat d d"
using Suc assms by auto
then show ?thesis by auto
qed
qed
lemma denote_while_n_sum_dim:
assumes "ρ ∈ carrier_mat d d"
"M0 ∈ carrier_mat d d"
"M1 ∈ carrier_mat d d"
"partial_density_operator ρ"
"⋀ρ'. ρ' ∈ carrier_mat d d ⟹ partial_density_operator ρ' ⟹ positive (DS ρ') ∧ trace (DS ρ') ≤ trace ρ' ∧ DS ρ' ∈ carrier_mat d d"
shows "matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n ∈ carrier_mat d d"
proof (induct n)
case 0
then show ?case by auto
next
case (Suc n)
then show ?case
proof -
have " denote_while_n M0 M1 DS n ρ ∈ carrier_mat d d"
using denote_while_n_dim assms by auto
then have "matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) (Suc n) ∈ carrier_mat d d"
using Suc by auto
then show ?thesis by auto
qed
qed
lemma trace_decrease_mul_adj:
assumes pdo: "partial_density_operator ρ" and dimr: "ρ ∈ carrier_mat d d"
and dimx: "x ∈ carrier_mat d d" and un: "adjoint x * x ≤⇩L 1⇩m d "
shows "trace (x * ρ * adjoint x) ≤ trace ρ"
proof -
have ad: "adjoint x * x ∈ carrier_mat d d" using adjoint_dim index_mult_mat dimx by auto
have "trace (x * ρ * adjoint x) = trace ((adjoint x * x) * ρ)" using dimx dimr by (mat_assoc d)
also have "… ≤ trace (1⇩m d * ρ)" using lowner_le_trace un ad dimr pdo by auto
also have "… = trace ρ" using dimr by auto
ultimately show ?thesis by auto
qed
lemma denote_while_n_positive:
assumes dim0: "M0 ∈ carrier_mat d d" and dim1: "M1 ∈ carrier_mat d d" and un: "adjoint M1 * M1 ≤⇩L 1⇩m d"
and DS: "⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ positive (DS ρ) ∧ trace (DS ρ) ≤ trace ρ ∧ DS ρ ∈ carrier_mat d d"
shows "partial_density_operator ρ ∧ ρ ∈ carrier_mat d d ⟹ positive (denote_while_n M0 M1 DS n ρ)"
proof (induction n arbitrary: ρ)
case 0
then show ?case using positive_close_under_left_right_mult_adjoint dim0 unfolding partial_density_operator_def by auto
next
case (Suc n)
then show ?case
proof -
have pdoM: "partial_density_operator (M1 * ρ * adjoint M1)" using pdo_close_under_measurement Suc dim1 un by auto
moreover have cM: "M1 * ρ * adjoint M1 ∈ carrier_mat d d" using Suc dim1 adjoint_dim index_mult_mat by auto
ultimately have DSM1: "positive (DS (M1 * ρ * adjoint M1)) ∧ trace (DS (M1 * ρ * adjoint M1)) ≤ trace (M1 * ρ * adjoint M1) ∧ DS (M1 * ρ * adjoint M1) ∈ carrier_mat d d"
using DS by auto
moreover have "trace (M1 * ρ * adjoint M1) ≤ trace ρ" using trace_decrease_mul_adj Suc dim1 un by auto
ultimately have "partial_density_operator (DS (M1 * ρ * adjoint M1))" using Suc unfolding partial_density_operator_def by auto
then have "positive (M0 * denote_while_n_iter M0 M1 DS n (DS (M1 * ρ * adjoint M1)) * adjoint M0)" using Suc DSM1 by auto
then have "positive (denote_while_n M0 M1 DS (Suc n) ρ)" by auto
then show ?thesis by auto
qed
qed
lemma denote_while_n_sum_positive:
assumes dim0: "M0 ∈ carrier_mat d d" and dim1: "M1 ∈ carrier_mat d d" and un: "adjoint M1 * M1 ≤⇩L 1⇩m d"
and DS: "⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ positive (DS ρ) ∧ trace (DS ρ) ≤ trace ρ ∧ DS ρ ∈ carrier_mat d d"
and pdo: "partial_density_operator ρ" and r: " ρ ∈ carrier_mat d d"
shows "positive (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n)"
proof -
have "⋀k. k < n ⟹ positive (denote_while_n M0 M1 DS k ρ)" using assms denote_while_n_positive by auto
moreover have "⋀k. k < n ⟹ denote_while_n M0 M1 DS k ρ ∈ carrier_mat d d" using denote_while_n_dim assms by auto
ultimately show ?thesis using matrix_sum_positive by auto
qed
lemma trace_measure2_id:
assumes dM0: "M0 ∈ carrier_mat n n" and dM1: "M1 ∈ carrier_mat n n"
and id: "adjoint M0 * M0 + adjoint M1 * M1 = 1⇩m n"
and dA: "A ∈ carrier_mat n n"
shows "trace (M0 * A * adjoint M0) + trace (M1 * A * adjoint M1) = trace A"
proof -
have "trace (M0 * A * adjoint M0) + trace (M1 * A * adjoint M1) = trace ((adjoint M0 * M0 + adjoint M1 * M1) * A)"
using assms by (mat_assoc n)
also have "… = trace (1⇩m n * A)" using id by auto
also have "… = trace A" using dA by auto
finally show ?thesis.
qed
lemma measurement_lowner_le_one1:
assumes dim0: "M0 ∈ carrier_mat d d" and dim1: "M1 ∈ carrier_mat d d" and id: "adjoint M0 * M0 + adjoint M1 * M1 = 1⇩m d"
shows "adjoint M1 * M1 ≤⇩L 1⇩m d"
proof -
have paM0: "positive (adjoint M0 * M0)"
apply (subgoal_tac "adjoint M0 * adjoint (adjoint M0) = adjoint M0 * M0")
subgoal using positive_if_decomp[of "adjoint M0 * M0"] dim0 adjoint_dim[OF dim0] by fastforce
using adjoint_adjoint[of M0] by auto
have le1: "adjoint M0 * M0 + adjoint M1 * M1 ≤⇩L 1⇩m d" using id lowner_le_refl[of "1⇩m d"] by fastforce
show "adjoint M1 * M1 ≤⇩L 1⇩m d"
using add_positive_le_reduce2[OF _ _ _ paM0 le1] dim0 dim1 by fastforce
qed
lemma denote_while_n_sum_trace:
assumes dim0: "M0 ∈ carrier_mat d d" and dim1: "M1 ∈ carrier_mat d d" and id: "adjoint M0 * M0 + adjoint M1 * M1 = 1⇩m d"
and DS: "⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ positive (DS ρ) ∧ trace (DS ρ) ≤ trace ρ ∧ DS ρ ∈ carrier_mat d d"
and r: " ρ ∈ carrier_mat d d"
and pdor: "partial_density_operator ρ"
shows "trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n) ≤ trace ρ"
proof -
have un: "adjoint M1 * M1 ≤⇩L 1⇩m d" using measurement_lowner_le_one1 using dim0 dim1 id by auto
have DS': "(DS ρ ∈ carrier_mat d d) ∧ partial_density_operator (DS ρ)" if "ρ ∈ carrier_mat d d" and "partial_density_operator ρ" for ρ
proof -
have res: "positive (DS ρ) ∧ trace (DS ρ) ≤ trace ρ ∧ DS ρ ∈ carrier_mat d d" using DS that by auto
moreover have "trace ρ ≤ 1" using that partial_density_operator_def by auto
ultimately have "trace (DS ρ) ≤ 1" by auto
with res show ?thesis unfolding partial_density_operator_def by auto
qed
have dWk: "denote_while_n_iter M0 M1 DS k ρ ∈ carrier_mat d d" for k
using denote_while_n_iter_dim[OF r pdor dim1 un] DS' dim0 dim1 by auto
have pdoWk: "partial_density_operator (denote_while_n_iter M0 M1 DS k ρ)" for k
using pdo_denote_while_n_iter[OF r pdor dim1 un] DS' dim0 dim1 by auto
have dW0k: "denote_while_n M0 M1 DS k ρ ∈ carrier_mat d d" for k using denote_while_n_dim r dim0 dim1 pdor by auto
then have dsW0k: "matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) k ∈ carrier_mat d d" for k
using matrix_sum_dim[of k "λk. denote_while_n M0 M1 DS k ρ"] by auto
have "(denote_while_n_comp M0 M1 DS n ρ) ∈ carrier_mat d d" for n unfolding denote_while_n_comp.simps using dim1 dWk by auto
moreover have
pdoW1k: "partial_density_operator (denote_while_n_comp M0 M1 DS n ρ)" for n unfolding denote_while_n_comp.simps
using pdo_close_under_measurement[OF dim1 dWk pdoWk un] by auto
ultimately have "trace (DS (denote_while_n_comp M0 M1 DS n ρ)) ≤ trace (denote_while_n_comp M0 M1 DS n ρ)" for n
using DS by auto
moreover have "trace (denote_while_n_iter M0 M1 DS (Suc n) ρ) = trace (DS (denote_while_n_comp M0 M1 DS n ρ))" for n
using denote_while_n_iter_assoc[folded denote_while_n_comp.simps] by auto
ultimately have leq3: "trace (denote_while_n_iter M0 M1 DS (Suc n) ρ) ≤ trace (denote_while_n_comp M0 M1 DS n ρ)" for n by auto
have mainleq: "trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) (Suc n)) + trace (denote_while_n_comp M0 M1 DS n ρ) ≤ trace ρ" for n
proof (induct n)
case 0
then show ?case unfolding matrix_sum.simps denote_while_n.simps denote_while_n_comp.simps denote_while_n_iter.simps
apply (subgoal_tac "M0 * ρ * adjoint M0 + 0⇩m d d = M0 * ρ * adjoint M0")
using trace_measure2_id[OF dim0 dim1 id r] dim0 apply simp
using dim0 by auto
next
case (Suc n)
have eq1: "trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) (Suc (Suc n)))
= trace (denote_while_n M0 M1 DS (Suc n) ρ) + trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) (Suc n))"
unfolding matrix_sum.simps
using trace_add_linear dW0k[of "Suc n"] dsW0k[of "Suc n"] by auto
have eq2: "trace (denote_while_n M0 M1 DS (Suc n) ρ) + trace (denote_while_n_comp M0 M1 DS (Suc n) ρ)
= trace (denote_while_n_iter M0 M1 DS (Suc n) ρ)"
unfolding denote_while_n.simps denote_while_n_comp.simps using trace_measure2_id[OF dim0 dim1 id dWk[of "Suc n"]] by auto
have "trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) (Suc (Suc n))) + trace (denote_while_n_comp M0 M1 DS (Suc n) ρ)
= trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) (Suc n)) + trace (denote_while_n M0 M1 DS (Suc n) ρ) + trace (denote_while_n_comp M0 M1 DS (Suc n) ρ)"
using eq1 by auto
also have "… = trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) (Suc n)) + trace (denote_while_n_iter M0 M1 DS (Suc n) ρ)"
using eq2 by auto
also have "… ≤ trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) (Suc n)) + trace (denote_while_n_comp M0 M1 DS n ρ)"
using leq3 by auto
also have "… ≤ trace ρ" using Suc by auto
finally show ?case.
qed
have reduce_le_complex: "(b::complex) ≥ 0 ⟹ a + b ≤ c ⟹ a ≤ c" for a b c by simp
have "positive (denote_while_n_comp M0 M1 DS n ρ)" for n using pdoW1k unfolding partial_density_operator_def by auto
then have "trace (denote_while_n_comp M0 M1 DS n ρ) ≥ 0" for n using positive_trace
using ‹⋀n. denote_while_n_comp M0 M1 DS n ρ ∈ carrier_mat d d› by blast
then have "trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) (Suc n)) ≤ trace ρ" for n
using mainleq reduce_le_complex[of "trace (denote_while_n_comp M0 M1 DS n ρ)"] by auto
moreover have "trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) 0) ≤ trace ρ"
unfolding matrix_sum.simps
using trace_zero positive_trace pdor unfolding partial_density_operator_def
using r by auto
ultimately show "trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n) ≤ trace ρ" for n
apply (induct n) by auto
qed
lemma denote_while_n_sum_partial_density:
assumes dim0: "M0 ∈ carrier_mat d d" and dim1: "M1 ∈ carrier_mat d d" and id: "adjoint M0 * M0 + adjoint M1 * M1 = 1⇩m d"
and DS: "⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ positive (DS ρ) ∧ trace (DS ρ) ≤ trace ρ ∧ DS ρ ∈ carrier_mat d d"
and pdo: "partial_density_operator ρ" and r: " ρ ∈ carrier_mat d d"
shows "(partial_density_operator (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n))"
proof -
have "trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n) ≤ trace ρ"
using denote_while_n_sum_trace assms by auto
then have "trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n) ≤ 1"
using pdo unfolding partial_density_operator_def by auto
moreover have "positive (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n)"
using assms DS denote_while_n_sum_positive measurement_lowner_le_one1[OF dim0 dim1 id] by auto
ultimately show ?thesis unfolding partial_density_operator_def by auto
qed
lemma denote_while_n_sum_lowner_le:
assumes dim0: "M0 ∈ carrier_mat d d" and dim1: "M1 ∈ carrier_mat d d" and id: "adjoint M0 * M0 + adjoint M1 * M1 = 1⇩m d"
and DS: "⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ positive (DS ρ) ∧ trace (DS ρ) ≤ trace ρ ∧ DS ρ ∈ carrier_mat d d"
and pdo: "partial_density_operator ρ" and dimr: " ρ ∈ carrier_mat d d"
shows "(matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n ≤⇩L matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) (Suc n))"
proof auto
have whilenc: "denote_while_n M0 M1 DS n ρ ∈ carrier_mat d d" using denote_while_n_dim assms by auto
have sumc: "matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n ∈ carrier_mat d d"
using denote_while_n_sum_dim assms by auto
have "denote_while_n M0 M1 DS n ρ + matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n - matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n
= denote_while_n M0 M1 DS n ρ + matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n + (- matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n)"
using minus_add_uminus_mat[of "matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n" d d "matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n"] by auto
also have "… = denote_while_n M0 M1 DS n ρ + 0⇩m d d"
by (smt assoc_add_mat minus_add_uminus_mat minus_r_inv_mat sumc uminus_carrier_mat whilenc)
also have "… = denote_while_n M0 M1 DS n ρ" using whilenc by auto
finally have simp: "denote_while_n M0 M1 DS n ρ + matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n - matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n =
denote_while_n M0 M1 DS n ρ " by auto
have "positive (denote_while_n M0 M1 DS n ρ)" using denote_while_n_positive assms measurement_lowner_le_one1[OF dim0 dim1 id] by auto
then have "matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n ≤⇩L (denote_while_n M0 M1 DS n ρ + matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n)"
unfolding lowner_le_def using simp by auto
then show "matrix_sum d (λn. M0 * denote_while_n_iter M0 M1 DS n ρ * adjoint M0) n ≤⇩L
(M0 * denote_while_n_iter M0 M1 DS n ρ * adjoint M0 + matrix_sum d (λn. M0 * denote_while_n_iter M0 M1 DS n ρ * adjoint M0) n)" by auto
qed
lemma lowner_is_lub_matrix_sum:
assumes dim0: "M0 ∈ carrier_mat d d" and dim1: "M1 ∈ carrier_mat d d" and id: "adjoint M0 * M0 + adjoint M1 * M1 = 1⇩m d"
and DS: "⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ positive (DS ρ) ∧ trace (DS ρ) ≤ trace ρ ∧ DS ρ ∈ carrier_mat d d"
and pdo: "partial_density_operator ρ" and dimr: " ρ ∈ carrier_mat d d"
shows "matrix_seq.lowner_is_lub (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ)) (matrix_seq.lowner_lub (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ)))"
proof-
have sumdd: "∀n. matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n ∈ carrier_mat d d"
using denote_while_n_sum_dim assms by auto
have sumtr: "∀n. trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n) ≤ trace ρ"
using denote_while_n_sum_trace assms by auto
have sumpar: "∀n. partial_density_operator (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n)"
using denote_while_n_sum_partial_density assms by auto
have sumle:"∀n. matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n ≤⇩L matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) (Suc n)"
using denote_while_n_sum_lowner_le assms by auto
have seqd: "matrix_seq d (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ))"
using matrix_seq_def sumdd sumpar sumle by auto
then show ?thesis using matrix_seq.lowner_lub_prop[of d "(matrix_sum d (λn. denote_while_n M0 M1 DS n ρ))"] by auto
qed
lemma denote_while_dim_positive:
assumes dim0: "M0 ∈ carrier_mat d d" and dim1: "M1 ∈ carrier_mat d d" and id: "adjoint M0 * M0 + adjoint M1 * M1 = 1⇩m d"
and DS: "⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ positive (DS ρ) ∧ trace (DS ρ) ≤ trace ρ ∧ DS ρ ∈ carrier_mat d d"
and pdo: "partial_density_operator ρ" and dimr: " ρ ∈ carrier_mat d d"
shows
"denote_while M0 M1 DS ρ ∈ carrier_mat d d ∧ positive (denote_while M0 M1 DS ρ) ∧ trace (denote_while M0 M1 DS ρ) ≤ trace ρ"
proof -
have sumdd: "∀n. matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n ∈ carrier_mat d d"
using denote_while_n_sum_dim assms by auto
have sumtr: "∀n. trace (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n) ≤ trace ρ"
using denote_while_n_sum_trace assms by auto
have sumpar: "∀n. partial_density_operator (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n)"
using denote_while_n_sum_partial_density assms by auto
have sumle:"∀n. matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) n ≤⇩L matrix_sum d (λn. denote_while_n M0 M1 DS n ρ) (Suc n)"
using denote_while_n_sum_lowner_le assms by auto
have seqd: "matrix_seq d (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ))"
using matrix_seq_def sumdd sumpar sumle by auto
have "matrix_seq.lowner_is_lub (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ)) (matrix_seq.lowner_lub (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ)))"
using lowner_is_lub_matrix_sum assms by auto
then have "matrix_seq.lowner_lub (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ)) ∈ carrier_mat d d
∧ positive (matrix_seq.lowner_lub (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ)))
∧ trace (matrix_seq.lowner_lub (matrix_sum d (λn. denote_while_n M0 M1 DS n ρ))) ≤ trace ρ"
using matrix_seq.lowner_is_lub_dim seqd matrix_seq.lowner_lub_is_positive matrix_seq.lowner_lub_trace sumtr by auto
then show ?thesis unfolding denote_while_def matrix_inf_sum_def by auto
qed
definition denote_measure :: "nat ⇒ (nat ⇒ complex mat) ⇒ ((state ⇒ state) list) ⇒ state ⇒ state" where
"denote_measure n M DS ρ = matrix_sum d (λk. (DS!k) ((M k) * ρ * adjoint (M k))) n"
lemma denote_measure_dim:
assumes "ρ ∈ carrier_mat d d"
"measurement d n M"
"⋀ρ' k. ρ' ∈ carrier_mat d d ⟹ k < n ⟹ (DS!k) ρ' ∈ carrier_mat d d"
shows
"denote_measure n M DS ρ ∈ carrier_mat d d"
proof -
have dMk: "k < n ⟹ M k ∈ carrier_mat d d" for k using assms measurement_def by auto
have d: "k < n ⟹ (M k) * ρ * adjoint (M k) ∈ carrier_mat d d" for k
using mult_carrier_mat[OF mult_carrier_mat[OF dMk assms(1)] adjoint_dim[OF dMk]] by auto
then have "k < n ⟹ (DS!k) ((M k) * ρ * adjoint (M k)) ∈ carrier_mat d d" for k using assms(3) by auto
then show ?thesis unfolding denote_measure_def using matrix_sum_dim[of n "λk. (DS!k) ((M k) * ρ * adjoint (M k))"] by auto
qed
lemma measure_well_com:
assumes "well_com (Measure n M S)"
shows "⋀k. k < n ⟹ well_com (S ! k)"
using assms unfolding well_com.simps using list_all_length by auto
text ‹Semantics of commands›
fun denote :: "com ⇒ state ⇒ state" where
"denote SKIP ρ = ρ"
| "denote (Utrans U) ρ = U * ρ * adjoint U"
| "denote (Seq S1 S2) ρ = denote S2 (denote S1 ρ)"
| "denote (Measure n M S) ρ = denote_measure n M (map denote S) ρ"
| "denote (While M S) ρ = denote_while (M 0) (M 1) (denote S) ρ"
lemma denote_measure_expand:
assumes m: "m ≤ n" and wc: "well_com (Measure n M S)"
shows "denote (Measure m M S) ρ = matrix_sum d (λk. denote (S!k) ((M k) * ρ * adjoint (M k))) m"
unfolding denote.simps denote_measure_def
proof -
have "k < m ⟹ map denote S ! k = denote (S!k)" for k using wc m by auto
then have "k < m ⟹ (map denote S ! k) (M k * ρ * adjoint (M k)) = denote (S!k) ((M k) * ρ * adjoint (M k))" for k by auto
then show "matrix_sum d (λk. (map denote S ! k) (M k * ρ * adjoint (M k))) m
= matrix_sum d (λk. denote (S ! k) (M k * ρ * adjoint (M k))) m"
using matrix_sum_cong[of m "λk. (map denote S ! k) (M k * ρ * adjoint (M k))" "λk. denote (S ! k) (M k * ρ * adjoint (M k))"] by auto
qed
lemma matrix_sum_trace_le:
fixes f :: "nat ⇒ complex mat" and g :: "nat ⇒ complex mat"
assumes "(⋀k. k < n ⟹ f k ∈ carrier_mat d d)"
"(⋀k. k < n ⟹ g k ∈ carrier_mat d d)"
"(⋀k. k < n ⟹ trace (f k) ≤ trace (g k))"
shows "trace (matrix_sum d f n) ≤ trace (matrix_sum d g n)"
proof -
have "sum (λk. trace (f k)) {0..<n} ≤ sum (λk. trace (g k)) {0..<n}"
using assms by (meson atLeastLessThan_iff sum_mono)
then show ?thesis using trace_matrix_sum_linear assms by auto
qed
lemma map_denote_positive_trace_dim:
assumes "well_com (Measure x1 x2a x3a)"
"x4 ∈ carrier_mat d d"
"partial_density_operator x4"
"⋀x3aa ρ. x3aa ∈ set x3a ⟹ well_com x3aa ⟹ ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ
⟹ positive (denote x3aa ρ) ∧ trace (denote x3aa ρ) ≤ trace ρ ∧ denote x3aa ρ ∈ carrier_mat d d"
shows "∀k < x1. positive ((map denote x3a ! k) (x2a k * x4 * adjoint (x2a k)))
∧ ((map denote x3a ! k) (x2a k * x4 * adjoint (x2a k))) ∈ carrier_mat d d
∧ trace ((map denote x3a ! k) (x2a k * x4 * adjoint (x2a k))) ≤ trace (x2a k * x4 * adjoint (x2a k))"
proof -
have x2ak: "∀ k < x1. x2a k ∈ carrier_mat d d" using assms(1) measurement_dim by auto
then have x2aa:"∀ k < x1. (x2a k * x4 * adjoint (x2a k)) ∈ carrier_mat d d" using assms(2) by fastforce
have posct: "positive ((map denote x3a ! k) (x2a k * x4 * adjoint (x2a k)))
∧ ((map denote x3a ! k) (x2a k * x4 * adjoint (x2a k))) ∈ carrier_mat d d
∧ trace ((map denote x3a ! k) (x2a k * x4 * adjoint (x2a k))) ≤ trace (x2a k * x4 * adjoint (x2a k))"
if k: "k < x1" for k
proof -
have lea: "adjoint (x2a k) * x2a k ≤⇩L 1⇩m d" using measurement_le_one_mat assms(1) k by auto
have "(x2a k * x4 * adjoint (x2a k)) ∈ carrier_mat d d" using k x2aa assms(2) by fastforce
moreover have "(x3a ! k) ∈ set x3a" using k assms(1) by simp
moreover have "well_com (x3a ! k)" using k assms(1) using measure_well_com by blast
moreover have "partial_density_operator (x2a k * x4 * adjoint (x2a k))"
using pdo_close_under_measurement x2ak assms(2,3) lea k by blast
ultimately have "positive (denote (x3a ! k) (x2a k * x4 * adjoint (x2a k)))
∧ (denote (x3a ! k) (x2a k * x4 * adjoint (x2a k))) ∈ carrier_mat d d
∧ trace (denote (x3a ! k) (x2a k * x4 * adjoint (x2a k))) ≤ trace (x2a k * x4 * adjoint (x2a k))"
using assms(4) by auto
then show ?thesis using assms(1) k by auto
qed
then show ?thesis by auto
qed
lemma denote_measure_positive_trace_dim:
assumes "well_com (Measure x1 x2a x3a)"
"x4 ∈ carrier_mat d d"
"partial_density_operator x4"
"⋀x3aa ρ. x3aa ∈ set x3a ⟹ well_com x3aa ⟹ ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ
⟹ positive (denote x3aa ρ) ∧ trace (denote x3aa ρ) ≤ trace ρ ∧ denote x3aa ρ ∈ carrier_mat d d"
shows "positive (denote (Measure x1 x2a x3a) x4) ∧ trace (denote (Measure x1 x2a x3a) x4) ≤ trace x4
∧ (denote (Measure x1 x2a x3a) x4) ∈ carrier_mat d d"
proof -
have x2ak: "∀ k < x1. x2a k ∈ carrier_mat d d" using assms(1) measurement_dim by auto
then have x2aa:"∀ k < x1. (x2a k * x4 * adjoint (x2a k)) ∈ carrier_mat d d" using assms(2) by fastforce
have posct:"∀ k < x1. positive ((map denote x3a ! k) (x2a k * x4 * adjoint (x2a k)))
∧ ((map denote x3a ! k) (x2a k * x4 * adjoint (x2a k))) ∈ carrier_mat d d
∧ trace ((map denote x3a ! k) (x2a k * x4 * adjoint (x2a k))) ≤ trace (x2a k * x4 * adjoint (x2a k))"
using map_denote_positive_trace_dim assms by auto
have "trace (matrix_sum d (λk. (map denote x3a ! k) (x2a k * x4 * adjoint (x2a k))) x1)
≤ trace (matrix_sum d (λk. (x2a k * x4 * adjoint (x2a k))) x1)"
using posct matrix_sum_trace_le[of x1 "(λk. (map denote x3a ! k) (x2a k * x4 * adjoint (x2a k)))" "(λk. x2a k * x4 * adjoint (x2a k)) "]
x2aa by auto
also have "… = trace x4" using trace_measurement[of d "x1" "x2a" x4] assms(1,2) by auto
finally have " trace (matrix_sum d (λk. (map denote x3a ! k) (x2a k * x4 * adjoint (x2a k))) x1) ≤ trace x4" by auto
then have "trace (denote_measure x1 x2a (map denote x3a) x4) ≤ trace x4"
unfolding denote_measure_def by auto
then have "trace (denote (Measure x1 x2a x3a) x4) ≤ trace x4" by auto
moreover from posct have "positive (denote (Measure x1 x2a x3a) x4)"
apply auto
unfolding denote_measure_def using matrix_sum_positive by auto
moreover have "(denote (Measure x1 x2a x3a) x4) ∈ carrier_mat d d"
apply auto
unfolding denote_measure_def using matrix_sum_dim posct
by (simp add: matrix_sum_dim)
ultimately show ?thesis by auto
qed
lemma denote_positive_trace_dim:
"well_com S ⟹ ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ
⟹ (positive (denote S ρ) ∧ trace (denote S ρ) ≤ trace ρ ∧ denote S ρ ∈ carrier_mat d d)"
proof (induction arbitrary: ρ)
case SKIP
then show ?case unfolding partial_density_operator_def by auto
next
case (Utrans x)
then show ?case
proof -
assume wc: "well_com (Utrans x)" and r: "ρ ∈ carrier_mat d d" and pdo: "partial_density_operator ρ"
show "positive (denote (Utrans x) ρ) ∧ trace (denote (Utrans x) ρ) ≤ trace ρ ∧ denote (Utrans x) ρ ∈ carrier_mat d d"
proof -
have "trace (x * ρ * adjoint x) = trace ((adjoint x * x) * ρ)"
using r apply (mat_assoc d) using wc by auto
also have "… = trace (1⇩m d * ρ)" using wc inverts_mat_def inverts_mat_symm adjoint_dim by auto
also have "… = trace ρ" using r by auto
finally have fst: "trace (x * ρ * adjoint x) = trace ρ" by auto
moreover have "positive (x * ρ * adjoint x)" using positive_close_under_left_right_mult_adjoint r pdo wc unfolding partial_density_operator_def by auto
moreover have "x * ρ * adjoint x ∈ carrier_mat d d" using r wc adjoint_dim index_mult_mat by auto
ultimately show ?thesis by auto
qed
qed
next
case (Seq x1 x2a)
then show ?case
proof -
assume dx1: "(⋀ρ. well_com x1 ⟹ ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ positive (denote x1 ρ) ∧ trace (denote x1 ρ) ≤ trace ρ ∧ denote x1 ρ ∈ carrier_mat d d)"
and dx2a: "(⋀ρ. well_com x2a ⟹ ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ positive (denote x2a ρ) ∧ trace (denote x2a ρ) ≤ trace ρ ∧ denote x2a ρ ∈ carrier_mat d d)"
and wc: "well_com (Seq x1 x2a)" and r: "ρ ∈ carrier_mat d d" and pdo: "partial_density_operator ρ"
show "positive (denote (Seq x1 x2a) ρ) ∧ trace (denote (Seq x1 x2a) ρ) ≤ trace ρ ∧ denote (Seq x1 x2a) ρ ∈ carrier_mat d d"
proof -
have ptc: "positive (denote x1 ρ) ∧ trace (denote x1 ρ) ≤ trace ρ ∧ denote x1 ρ ∈ carrier_mat d d"
using wc r pdo dx1 by auto
then have "partial_density_operator (denote x1 ρ)" using pdo unfolding partial_density_operator_def by auto
then show ?thesis using ptc dx2a wc dual_order.trans by auto
qed
qed
next
case (Measure x1 x2a x3a)
then show ?case using denote_measure_positive_trace_dim by auto
next
case (While x1 x2a)
then show ?case
proof -
have "adjoint (x1 0) * (x1 0) + adjoint (x1 1) * (x1 1) = 1⇩m d"
using measurement_id2 While by auto
moreover have "(⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹
positive (denote x2a ρ) ∧ trace (denote x2a ρ) ≤ trace ρ ∧ denote x2a ρ ∈ carrier_mat d d)"
using While by fastforce
moreover have "x1 0 ∈ carrier_mat d d ∧ x1 1 ∈ carrier_mat d d"
using measurement_dim While by fastforce
ultimately have "denote_while (x1 0) (x1 1) (denote x2a) ρ ∈ carrier_mat d d ∧
positive (denote_while (x1 0) (x1 1) (denote x2a) ρ) ∧
trace (denote_while (x1 0) (x1 1) (denote x2a) ρ) ≤ trace ρ"
using denote_while_dim_positive[of "x1 0" "x1 1" "denote x2a" "ρ"] While by fastforce
then show ?thesis by auto
qed
qed
lemma denote_dim_pdo:
"well_com S ⟹ ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ
⟹ (denote S ρ ∈ carrier_mat d d) ∧ (partial_density_operator (denote S ρ))"
using denote_positive_trace_dim unfolding partial_density_operator_def by fastforce
lemma denote_dim:
"well_com S ⟹ ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ
⟹ (denote S ρ ∈ carrier_mat d d)"
using denote_positive_trace_dim by auto
lemma denote_trace:
"well_com S ⟹ ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ
⟹ trace (denote S ρ) ≤ trace ρ"
using denote_positive_trace_dim by auto
lemma denote_partial_density_operator:
assumes "well_com S" "partial_density_operator ρ" "ρ ∈ carrier_mat d d"
shows "partial_density_operator (denote S ρ)"
using assms denote_positive_trace_dim unfolding partial_density_operator_def
using dual_order.trans by blast
lemma denote_while_n_sum_mat_seq:
assumes "ρ ∈ carrier_mat d d" and
"x1 0 ∈ carrier_mat d d" and
"x1 1 ∈ carrier_mat d d" and
"partial_density_operator ρ" and
wc: "well_com x2" and mea: "measurement d 2 x1"
shows "matrix_seq d (matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ))"
proof -
let ?A = "x1 0" and ?B = "x1 1"
have dx2:"⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹
positive ((denote x2) ρ) ∧ trace ((denote x2) ρ) ≤ trace ρ ∧ (denote x2) ρ ∈ carrier_mat d d"
using denote_positive_trace_dim wc by auto
have lo1: "adjoint ?A * ?A + adjoint ?B * ?B = 1⇩m d" using measurement_id2 assms by auto
have "∀n. matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ) n ∈ carrier_mat d d"
using assms dx2
by (metis denote_while_n_dim matrix_sum_dim)
moreover have "(∀n. partial_density_operator (matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ) n))"
using assms dx2 lo1
by (metis denote_while_n_sum_partial_density)
moreover have "(∀n. matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ) n ≤⇩L matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ) (Suc n))"
using assms dx2 lo1
by (metis denote_while_n_sum_lowner_le)
ultimately show ?thesis
unfolding matrix_seq_def by auto
qed
lemma denote_while_n_add:
assumes M0: "x1 0 ∈ carrier_mat d d" and
M1: "x1 1 ∈ carrier_mat d d" and
wc: "well_com x2" and mea: "measurement d 2 x1" and
DS: "(⋀ρ⇩1 ρ⇩2. ρ⇩1 ∈ carrier_mat d d ⟹ ρ⇩2 ∈ carrier_mat d d ⟹ partial_density_operator ρ⇩1 ⟹
partial_density_operator ρ⇩2 ⟹ trace (ρ⇩1 + ρ⇩2) ≤ 1 ⟹ denote x2 (ρ⇩1 + ρ⇩2) = denote x2 ρ⇩1 + denote x2 ρ⇩2)"
shows "ρ⇩1 ∈ carrier_mat d d ⟹ ρ⇩2 ∈ carrier_mat d d ⟹ partial_density_operator ρ⇩1 ⟹ partial_density_operator ρ⇩2 ⟹ trace (ρ⇩1 + ρ⇩2) ≤ 1 ⟹
denote_while_n (x1 0) (x1 1) (denote x2) k (ρ⇩1 + ρ⇩2) = denote_while_n (x1 0) (x1 1) (denote x2) k ρ⇩1 + denote_while_n (x1 0) (x1 1) (denote x2) k ρ⇩2"
proof (auto, induct k arbitrary: ρ⇩1 ρ⇩2)
case 0
then show ?case
apply auto using M0 by (mat_assoc d)
next
case (Suc k)
then show ?case
proof -
let ?A = "x1 0" and ?B = "x1 1"
have dx2:"(⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ positive ((denote x2) ρ) ∧ trace ((denote x2) ρ) ≤ trace ρ ∧ (denote x2) ρ ∈ carrier_mat d d) "
using denote_positive_trace_dim wc by auto
have lo1: "adjoint ?B * ?B ≤⇩L 1⇩m d" using measurement_le_one_mat assms by auto
have dim1: "x1 1 * ρ⇩1 * adjoint (x1 1) ∈ carrier_mat d d" using assms Suc
by (metis adjoint_dim mult_carrier_mat)
moreover have pdo1: "partial_density_operator (x1 1 * ρ⇩1 * adjoint (x1 1))"
using pdo_close_under_measurement assms(2) Suc(2,4) lo1 by auto
ultimately have dimr1: "denote x2 (x1 1 * ρ⇩1 * adjoint (x1 1)) ∈ carrier_mat d d"
using dx2 by auto
have dim2: "x1 1 * ρ⇩2 * adjoint (x1 1) ∈ carrier_mat d d" using assms Suc
by (metis adjoint_dim mult_carrier_mat)
moreover have pdo2: "partial_density_operator (x1 1 * ρ⇩2 * adjoint (x1 1))"
using pdo_close_under_measurement assms(2) Suc lo1 by auto
ultimately have dimr2: "denote x2 (x1 1 * ρ⇩2 * adjoint (x1 1)) ∈ carrier_mat d d"
using dx2 by auto
have pdor1: "partial_density_operator (denote x2 (x1 1 * ρ⇩1 * adjoint (x1 1)))"
using denote_partial_density_operator assms dim1 pdo1 by auto
have pdor2: "partial_density_operator (denote x2 (x1 1 * ρ⇩2 * adjoint (x1 1)))"
using denote_partial_density_operator assms dim2 pdo2 by auto
have "trace (denote x2 (x1 1 * ρ⇩1 * adjoint (x1 1))) ≤ trace (x1 1 * ρ⇩1 * adjoint (x1 1))"
using dx2 dim1 pdo1 by auto
also have tr1: "… ≤ trace ρ⇩1" using trace_decrease_mul_adj assms Suc lo1 by auto
finally have trr1:" trace (denote x2 (x1 1 * ρ⇩1 * adjoint (x1 1))) ≤ trace ρ⇩1" by auto
have "trace (denote x2 (x1 1 * ρ⇩2 * adjoint (x1 1))) ≤ trace (x1 1 * ρ⇩2 * adjoint (x1 1))"
using dx2 dim2 pdo2 by auto
also have tr2: "… ≤ trace ρ⇩2" using trace_decrease_mul_adj assms Suc lo1 by auto
finally have trr2:" trace (denote x2 (x1 1 * ρ⇩2 * adjoint (x1 1))) ≤ trace ρ⇩2" by auto
from tr1 tr2 Suc have "trace ( (x1 1 * ρ⇩1 * adjoint (x1 1)) + (x1 1 * ρ⇩2 * adjoint (x1 1))) ≤ trace (ρ⇩1 + ρ⇩2)"
using trace_add_linear trace_add_linear[of "(x1 1 * ρ⇩1 * adjoint (x1 1))" d "(x1 1 * ρ⇩2 * adjoint (x1 1))"]
trace_add_linear[of ρ⇩1 d ρ⇩2]
using dim1 dim2 by auto
then have trless1: "trace ( (x1 1 * ρ⇩1 * adjoint (x1 1)) + (x1 1 * ρ⇩2 * adjoint (x1 1))) ≤ 1" using Suc by auto
from trr1 trr2 Suc have "trace (denote x2 (x1 1 * ρ⇩1 * adjoint (x1 1)) + denote x2 (x1 1 * ρ⇩2 * adjoint (x1 1))) ≤ trace (ρ⇩1 + ρ⇩2)"
using trace_add_linear[of "denote x2 (x1 1 * ρ⇩1 * adjoint (x1 1))" d "denote x2 (x1 1 * ρ⇩2 * adjoint (x1 1))"]
trace_add_linear[of ρ⇩1 d ρ⇩2]
using dimr1 dimr2 by auto
then have trless2: "trace (denote x2 (x1 1 * ρ⇩1 * adjoint (x1 1)) + denote x2 (x1 1 * ρ⇩2 * adjoint (x1 1))) ≤ 1"
using Suc by auto
have "x1 1 * (ρ⇩1 + ρ⇩2) * adjoint (x1 1) = (x1 1 * ρ⇩1 * adjoint (x1 1)) + (x1 1 * ρ⇩2 * adjoint (x1 1))"
using M1 Suc by (mat_assoc d)
then have deadd: "denote x2 (x1 1 * (ρ⇩1 + ρ⇩2) * adjoint (x1 1)) =
denote x2 (x1 1 * ρ⇩1 * adjoint (x1 1)) + denote x2 (x1 1 * ρ⇩2 * adjoint (x1 1))"
using assms(5) dim1 dim2 pdo1 pdo2 trless1 by auto
from dimr1 dimr2 pdor1 pdor2 trless2 Suc(1) deadd show ?thesis by auto
qed
qed
lemma denote_while_add:
assumes r1: "ρ⇩1 ∈ carrier_mat d d" and
r2: "ρ⇩2 ∈ carrier_mat d d" and
M0: "x1 0 ∈ carrier_mat d d" and
M1: "x1 1 ∈ carrier_mat d d" and
pdo1: "partial_density_operator ρ⇩1" and
pdo2: "partial_density_operator ρ⇩2" and tr12: "trace (ρ⇩1 + ρ⇩2) ≤ 1" and
wc: "well_com x2" and mea: "measurement d 2 x1" and
DS: "(⋀ρ⇩1 ρ⇩2. ρ⇩1 ∈ carrier_mat d d ⟹ ρ⇩2 ∈ carrier_mat d d ⟹ partial_density_operator ρ⇩1 ⟹
partial_density_operator ρ⇩2 ⟹ trace (ρ⇩1 + ρ⇩2) ≤ 1 ⟹ denote x2 (ρ⇩1 + ρ⇩2) = denote x2 ρ⇩1 + denote x2 ρ⇩2)"
shows
"denote_while (x1 0) (x1 1) (denote x2) (ρ⇩1 + ρ⇩2) = denote_while (x1 0) (x1 1) (denote x2) ρ⇩1 + denote_while (x1 0) (x1 1) (denote x2) ρ⇩2"
proof -
let ?A = "x1 0" and ?B = "x1 1"
have dx2:"(⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ positive ((denote x2) ρ) ∧ trace ((denote x2) ρ) ≤ trace ρ ∧ (denote x2) ρ ∈ carrier_mat d d) "
using denote_positive_trace_dim wc by auto
have lo1: "adjoint ?A * ?A + adjoint ?B * ?B = 1⇩m d" using measurement_id2 assms by auto
have pdo12: "partial_density_operator (ρ⇩1 + ρ⇩2)" using pdo1 pdo2 unfolding partial_density_operator_def using tr12 positive_add assms by auto
have ms1: "matrix_seq d (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩1))"
using denote_while_n_sum_mat_seq assms by auto
have ms2: "matrix_seq d (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩2))"
using denote_while_n_sum_mat_seq assms by auto
have dim1: "(∀n. matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ⇩1) n ∈ carrier_mat d d)"
using assms dx2
by (metis denote_while_n_dim matrix_sum_dim)
have dim2: "(∀n. matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ⇩2) n ∈ carrier_mat d d)"
using assms dx2
by (metis denote_while_n_dim matrix_sum_dim)
have "trace (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩1) n +
matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩2) n) ≤ trace (ρ⇩1 + ρ⇩2)"
for n
proof -
have "trace (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩1) n) ≤ trace ρ⇩1"
using denote_while_n_sum_trace dx2 lo1 assms by auto
moreover have "trace (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩2) n) ≤ trace ρ⇩2"
using denote_while_n_sum_trace dx2 lo1 assms by auto
ultimately show ?thesis
using trace_add_linear dim1 dim2
by (metis add_mono_thms_linordered_semiring(1) r1 r2)
qed
then have "∀n. trace (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩1) n + matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩2) n) ≤ 1"
using assms(7) dual_order.trans by blast
then have lladd: "matrix_seq.lowner_lub (λn. (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩1)) n + (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩2)) n) = matrix_seq.lowner_lub (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩1))
+ matrix_seq.lowner_lub (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩2))"
using lowner_lub_add ms1 ms2 by auto
have "matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n (ρ⇩1 + ρ⇩2)) m =
matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩1) m + matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩2) m"
for m
proof -
have "(⋀k. k < m ⟹ denote_while_n (x1 0) (x1 1) (denote x2) k (ρ⇩1 + ρ⇩2) ∈ carrier_mat d d)"
using denote_while_n_dim dx2 pdo12 assms measurement_dim by auto
moreover have "(⋀k. k < m ⟹ denote_while_n (x1 0) (x1 1) (denote x2) k ρ⇩1 ∈ carrier_mat d d)"
using denote_while_n_dim dx2 assms measurement_dim by auto
moreover have "(⋀k. k < m ⟹ denote_while_n (x1 0) (x1 1) (denote x2) k ρ⇩2 ∈ carrier_mat d d)"
using denote_while_n_dim dx2 assms measurement_dim by auto
moreover have "(∀ k < m.
denote_while_n (x1 0) (x1 1) (denote x2) k (ρ⇩1 + ρ⇩2) = denote_while_n (x1 0) (x1 1) (denote x2) k ρ⇩1 + denote_while_n (x1 0) (x1 1) (denote x2) k ρ⇩2)"
using denote_while_n_add assms by auto
ultimately show ?thesis
using matrix_sum_add[of m "(λn. denote_while_n (x1 0) (x1 1) (denote x2) n (ρ⇩1 + ρ⇩2))" d "(λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ⇩1)"
"(λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ⇩2)"] by auto
qed
then have "matrix_seq.lowner_lub (matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n (ρ⇩1 + ρ⇩2))) =
matrix_seq.lowner_lub (λn. (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩1)) n + (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ⇩2)) n)"
using lladd by presburger
then show ?thesis unfolding denote_while_def matrix_inf_sum_def using lladd by auto
qed
lemma denote_add:
"well_com S ⟹ ρ⇩1 ∈ carrier_mat d d ⟹ ρ⇩2 ∈ carrier_mat d d ⟹
partial_density_operator ρ⇩1 ⟹ partial_density_operator ρ⇩2 ⟹ trace (ρ⇩1 + ρ⇩2) ≤ 1 ⟹
denote S (ρ⇩1 + ρ⇩2) = denote S ρ⇩1 + denote S ρ⇩2"
proof (induction arbitrary: ρ⇩1 ρ⇩2)
case SKIP
then show ?case by auto
next
case (Utrans U)
then show ?case by (clarsimp, mat_assoc d)
next
case (Seq x1 x2a)
then show ?case
proof -
have dim1: "denote x1 ρ⇩1 ∈ carrier_mat d d" using denote_positive_trace_dim Seq by auto
have dim2: "denote x1 ρ⇩2 ∈ carrier_mat d d" using denote_positive_trace_dim Seq by auto
have "trace (denote x1 ρ⇩1) ≤ trace ρ⇩1" using denote_positive_trace_dim Seq by auto
moreover have "trace (denote x1 ρ⇩2) ≤ trace ρ⇩2" using denote_positive_trace_dim Seq by auto
ultimately have tr: "trace (denote x1 ρ⇩1 + denote x1 ρ⇩2) ≤ 1" using Seq(4,5,8) trace_add_linear dim1 dim2
by (smt add_mono order_trans)
have "denote (Seq x1 x2a) (ρ⇩1 + ρ⇩2) = denote x2a (denote x1 (ρ⇩1 + ρ⇩2))" by auto
moreover have "denote x1 (ρ⇩1 + ρ⇩2) = denote x1 ρ⇩1 + denote x1 ρ⇩2" using Seq by auto
moreover have "partial_density_operator (denote x1 ρ⇩1)" using denote_partial_density_operator Seq by auto
moreover have "partial_density_operator (denote x1 ρ⇩2)" using denote_partial_density_operator Seq by auto
ultimately show ?thesis using Seq dim1 dim2 tr by auto
qed
next
case (Measure x1 x2a x3a)
then show ?case
proof -
have ptc: "⋀x3aa ρ. x3aa ∈ set x3a ⟹ well_com x3aa ⟹ ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ
⟹ positive (denote x3aa ρ) ∧ trace (denote x3aa ρ) ≤ trace ρ ∧ denote x3aa ρ ∈ carrier_mat d d"
using denote_positive_trace_dim Measure by auto
then have map:"⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ ∀ k < x1. positive ((map denote x3a ! k) (x2a k * ρ * adjoint (x2a k)))
∧ ((map denote x3a ! k) (x2a k * ρ * adjoint (x2a k))) ∈ carrier_mat d d
∧ trace ((map denote x3a ! k) (x2a k * ρ * adjoint (x2a k))) ≤ trace (x2a k * ρ * adjoint (x2a k))"
using Measure map_denote_positive_trace_dim by auto
from map have mapd1: "⋀k. k < x1 ⟹ (map denote x3a ! k) (x2a k * ρ⇩1 * adjoint (x2a k)) ∈ carrier_mat d d"
using Measure by auto
from map have mapd2: "⋀k. k < x1 ⟹ (map denote x3a ! k) (x2a k * ρ⇩2 * adjoint (x2a k)) ∈ carrier_mat d d"
using Measure by auto
have dim1:"⋀k. k < x1 ⟹ x2a k * ρ⇩1 * adjoint (x2a k) ∈ carrier_mat d d"
using well_com.simps(5) measurement_dim Measure by fastforce
have dim2: "⋀k. k < x1 ⟹ x2a k * ρ⇩2 * adjoint (x2a k) ∈ carrier_mat d d"
using well_com.simps(5) measurement_dim Measure by fastforce
have "⋀k. k < x1 ⟹ (x2a k * (ρ⇩1 + ρ⇩2) * adjoint (x2a k)) ∈ carrier_mat d d"
using well_com.simps(5) measurement_dim Measure by fastforce
have lea: "⋀k. k < x1 ⟹ adjoint (x2a k) * x2a k ≤⇩L 1⇩m d" using measurement_le_one_mat Measure by auto
moreover have dimx: "⋀k. k < x1 ⟹ x2a k ∈ carrier_mat d d" using Measure measurement_dim by auto
ultimately have pdo12:"⋀k. k < x1 ⟹ partial_density_operator (x2a k * ρ⇩1 * adjoint (x2a k)) ∧ partial_density_operator (x2a k * ρ⇩2 * adjoint (x2a k))"
using pdo_close_under_measurement Measure measurement_dim by blast
have trless: "trace (x2a k * ρ⇩1 * adjoint (x2a k) + x2a k * ρ⇩2 * adjoint (x2a k)) ≤ 1"
if k: "k < x1" for k
proof -
have "trace (x2a k * ρ⇩1 * adjoint (x2a k)) ≤ trace ρ⇩1" using trace_decrease_mul_adj dimx Measure lea k by auto
moreover have "trace (x2a k * ρ⇩2 * adjoint (x2a k)) ≤ trace ρ⇩2" using trace_decrease_mul_adj dimx Measure lea k by auto
ultimately have "trace (x2a k * ρ⇩1 * adjoint (x2a k) + x2a k * ρ⇩2 * adjoint (x2a k)) ≤ trace (ρ⇩1 + ρ⇩2)"
using trace_add_linear dim1 dim2 Measure k
by (metis add_mono_thms_linordered_semiring(1))
then show ?thesis using Measure(7) by auto
qed
have dist: "(x2a k * (ρ⇩1 + ρ⇩2) * adjoint (x2a k)) = (x2a k * ρ⇩1 * adjoint (x2a k)) + (x2a k * ρ⇩2 * adjoint (x2a k))"
if k: "k < x1" for k
proof -
have "(x2a k * (ρ⇩1 + ρ⇩2) * adjoint (x2a k)) = ((x2a k * ρ⇩1 + x2a k * ρ⇩2) * adjoint (x2a k))"
using mult_add_distrib_mat Measure well_com.simps(4) measurement_dim by (metis k)
also have "… = (x2a k * ρ⇩1 * adjoint (x2a k)) + (x2a k * ρ⇩2 * adjoint (x2a k))"
apply (mat_assoc d) using Measure k well_com.simps(4) measurement_dim by auto
finally show ?thesis by auto
qed
have mapadd: "(map denote x3a ! k) (x2a k * (ρ⇩1 + ρ⇩2) * adjoint (x2a k)) =
(map denote x3a ! k) (x2a k * ρ⇩1 * adjoint (x2a k)) + (map denote x3a ! k) (x2a k * ρ⇩2 * adjoint (x2a k))"
if k: "k < x1" for k
proof -
have "(map denote x3a ! k) (x2a k * (ρ⇩1 + ρ⇩2) * adjoint (x2a k)) = denote (x3a ! k) (x2a k * (ρ⇩1 + ρ⇩2) * adjoint (x2a k))"
using Measure.prems(1) k by auto
then have mapx: "(map denote x3a ! k) (x2a k * (ρ⇩1 + ρ⇩2) * adjoint (x2a k)) = denote (x3a ! k) ((x2a k * ρ⇩1 * adjoint (x2a k)) + (x2a k * ρ⇩2 * adjoint (x2a k)))"
using dist k by auto
have "denote (x3a ! k) ((x2a k * ρ⇩1 * adjoint (x2a k)) + (x2a k * ρ⇩2 * adjoint (x2a k)))
= denote (x3a ! k) (x2a k * ρ⇩1 * adjoint (x2a k)) + denote (x3a ! k) (x2a k * ρ⇩2 * adjoint (x2a k))"
using Measure(1,2) dim1 dim2 pdo12 trless k
by (simp add: list_all_length)
then show ?thesis
using Measure.prems(1) mapx k by auto
qed
then have mapd12:"(⋀k. k < x1 ⟹ (map denote x3a ! k) (x2a k * (ρ⇩1 + ρ⇩2) * adjoint (x2a k)) ∈ carrier_mat d d)"
using mapd1 mapd2 by auto
have "matrix_sum d (λk. (map denote x3a ! k) (x2a k * (ρ⇩1 + ρ⇩2) * adjoint (x2a k))) x1 =
matrix_sum d (λk. (map denote x3a ! k) (x2a k * ρ⇩1 * adjoint (x2a k))) x1 +
matrix_sum d (λk. (map denote x3a ! k) (x2a k * ρ⇩2 * adjoint (x2a k))) x1"
using matrix_sum_add[of x1 "(λk. (map denote x3a ! k) (x2a k * (ρ⇩1 + ρ⇩2) * adjoint (x2a k)))" d "(λk. (map denote x3a ! k) (x2a k * ρ⇩1 * adjoint (x2a k)))" "(λk. (map denote x3a ! k) (x2a k * ρ⇩2 * adjoint (x2a k)))"]
using mapd12 mapd1 mapd2 mapadd by auto
then show ?thesis using denote.simps(4) unfolding denote_measure_def by auto
qed
next
case (While x1 x2)
then show ?case
apply auto using denote_while_add measurement_dim by auto
qed
lemma mulfact:
fixes c:: real and a:: complex and b:: complex
assumes "c≥0" "a ≤ b"
shows "c * a ≤ c * b"
using assms mult_le_cancel_iff2 by force
lemma denote_while_n_scale:
fixes c:: real
assumes "c≥0"
"measurement d 2 x1" "well_com x2"
"(⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ trace (c ⋅⇩m ρ) ≤ 1 ⟹
denote x2 (c ⋅⇩m ρ) = c ⋅⇩m denote x2 ρ)"
shows "ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ trace (c ⋅⇩m ρ) ≤ 1 ⟹
denote_while_n (x1 0) (x1 1) (denote x2) n (complex_of_real c ⋅⇩m ρ) = c ⋅⇩m (denote_while_n (x1 0) (x1 1) (denote x2) n ρ)"
proof (auto, induct n arbitrary: ρ)
case 0
then show ?case
apply auto apply (mat_assoc d) using assms measurement_dim by auto
next
case (Suc n)
then show ?case
proof -
let ?A = "x1 0" and ?B = "x1 1"
have dx2:"(⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ positive ((denote x2) ρ) ∧ trace ((denote x2) ρ) ≤ trace ρ ∧ (denote x2) ρ ∈ carrier_mat d d) "
using denote_positive_trace_dim assms by auto
have lo1: "adjoint ?B * ?B ≤⇩L 1⇩m d" using measurement_le_one_mat assms by auto
have dim1: "x1 1 * ρ * adjoint (x1 1) ∈ carrier_mat d d" using assms(2) Suc(2) measurement_dim
by (meson adjoint_dim mult_carrier_mat one_less_numeral_iff semiring_norm(76))
moreover have pdo1: "partial_density_operator (x1 1 * ρ * adjoint (x1 1))"
using pdo_close_under_measurement assms Suc lo1 measurement_dim
by (metis One_nat_def lessI numeral_2_eq_2)
ultimately have dimr: "denote x2 (x1 1 * ρ * adjoint (x1 1)) ∈ carrier_mat d d"
using dx2 by auto
have pdor: "partial_density_operator (denote x2 (x1 1 * ρ * adjoint (x1 1)))"
using denote_partial_density_operator assms dim1 pdo1 by auto
have "trace (denote x2 (x1 1 * ρ * adjoint (x1 1))) ≤ trace (x1 1 * ρ * adjoint (x1 1))"
using dx2 dim1 pdo1 by auto
also have trr1: "… ≤ trace ρ" using trace_decrease_mul_adj assms Suc lo1 measurement_dim by auto
finally have trr: "trace (denote x2 (x1 1 * ρ * adjoint (x1 1))) ≤ trace ρ" by auto
moreover have "trace (c ⋅⇩m denote x2 (x1 1 * ρ * adjoint (x1 1))) = c * trace (denote x2 (x1 1 * ρ * adjoint (x1 1)))"
using trace_smult dimr by auto
moreover have trcr: "trace (c ⋅⇩m ρ) = c * trace ρ" using trace_smult Suc by auto
ultimately have "trace (c ⋅⇩m denote x2 (x1 1 * ρ * adjoint (x1 1))) ≤ trace (c ⋅⇩m ρ)"
using assms(1) state_sig.mulfact by auto
then have trrc: "trace (c ⋅⇩m denote x2 (x1 1 * ρ * adjoint (x1 1))) ≤ 1" using Suc by auto
have "trace (c ⋅⇩m (x1 1 * ρ * adjoint (x1 1))) = c * trace (x1 1 * ρ * adjoint (x1 1))"
using trace_smult dim1 by auto
then have "trace (c ⋅⇩m (x1 1 * ρ * adjoint (x1 1))) ≤ trace (c ⋅⇩m ρ)" using trcr trr1 assms(1)
using state_sig.mulfact by auto
then have trrle: "trace (c ⋅⇩m (x1 1 * ρ * adjoint (x1 1))) ≤ 1" using Suc by auto
have "x1 1 * (complex_of_real c ⋅⇩m ρ) * adjoint (x1 1) = complex_of_real c ⋅⇩m (x1 1 * ρ * adjoint (x1 1))"
apply (mat_assoc d) using Suc.prems(1) assms measurement_dim by auto
then have "denote x2 (x1 1 * (complex_of_real c ⋅⇩m ρ) * adjoint (x1 1)) = (denote x2 (c ⋅⇩m (x1 1 * (ρ) * adjoint (x1 1))))"
by auto
moreover have "denote x2 (c ⋅⇩m (x1 1 * ρ * adjoint (x1 1))) = c ⋅⇩m denote x2 (x1 1 * ρ * adjoint (x1 1))"
using assms(4) dim1 pdo1 trrle by auto
ultimately have "denote x2 (x1 1 * (complex_of_real c ⋅⇩m ρ) * adjoint (x1 1)) = c ⋅⇩m denote x2 (x1 1 * ρ * adjoint (x1 1))"
using assms by auto
then show ?thesis using Suc dimr pdor trrc by auto
qed
qed
lemma denote_while_scale:
fixes c:: real
assumes "ρ ∈ carrier_mat d d"
"partial_density_operator ρ"
"trace (c ⋅⇩m ρ) ≤ 1" "c ≥ 0"
"measurement d 2 x1" "well_com x2"
"(⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ trace (c ⋅⇩m ρ) ≤ 1 ⟹
denote x2 (c ⋅⇩m ρ) = c ⋅⇩m denote x2 ρ)"
shows "denote_while (x1 0) (x1 1) (denote x2) (c ⋅⇩m ρ) = c ⋅⇩m denote_while (x1 0) (x1 1) (denote x2) ρ"
proof -
let ?A = "x1 0" and ?B = "x1 1"
have dx2:"(⋀ρ. ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹ positive ((denote x2) ρ) ∧ trace ((denote x2) ρ) ≤ trace ρ ∧ (denote x2) ρ ∈ carrier_mat d d) "
using denote_positive_trace_dim assms by auto
have lo1: "adjoint ?A * ?A + adjoint ?B * ?B = 1⇩m d" using measurement_id2 assms by auto
have ms: "matrix_seq d (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ))"
using denote_while_n_sum_mat_seq assms measurement_dim by auto
have trcless: "trace (c ⋅⇩m matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ) n) ≤ 1" for n
proof -
have dimr: "matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ) n ∈ carrier_mat d d"
using assms dx2 denote_while_n_dim matrix_sum_dim
using matrix_seq.dim ms by auto
have "trace (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ) n) ≤ trace ρ"
using denote_while_n_sum_trace dx2 lo1 assms measurement_dim by auto
moreover have "trace (c ⋅⇩m matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ) n) = c * trace (matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ) n)"
using trace_smult dimr by auto
moreover have "trace (c ⋅⇩m ρ) = c * trace ρ" using trace_smult assms by auto
ultimately have "trace (c ⋅⇩m matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ) n) ≤ trace (c ⋅⇩m ρ)"
using assms(4) by (simp add: ordered_comm_semiring_class.comm_mult_left_mono)
then show ?thesis
using assms by auto
qed
have llscale: "matrix_seq.lowner_lub (λn. c ⋅⇩m (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ)) n)
= c ⋅⇩m matrix_seq.lowner_lub (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ))"
using lowner_lub_scale[of d "(matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ))" c] ms trcless assms(4) by auto
have "matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n (complex_of_real c ⋅⇩m ρ)) m
= c ⋅⇩m (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ)) m"
for m
proof -
have dim:"(⋀k. k < m ⟹ denote_while_n (x1 0) (x1 1) (denote x2) k ρ ∈ carrier_mat d d)"
using denote_while_n_dim dx2 assms measurement_dim by auto
then have dimr: "(⋀k. k < m ⟹ c ⋅⇩m denote_while_n (x1 0) (x1 1) (denote x2) k ρ ∈ carrier_mat d d)"
using smult_carrier_mat by auto
have "∀ n<m. denote_while_n (x1 0) (x1 1) (denote x2) n (complex_of_real c ⋅⇩m ρ) = c ⋅⇩m (denote_while_n (x1 0) (x1 1) (denote x2) n ρ)"
using denote_while_n_scale assms by auto
then have "(matrix_sum d (λn. c ⋅⇩m denote_while_n ?A ?B (denote x2) n ρ)) m =
matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n (complex_of_real c ⋅⇩m ρ)) m "
using matrix_sum_cong[of m "λn. complex_of_real c ⋅⇩m denote_while_n (x1 0) (x1 1) (denote x2) n ρ"] dimr
by fastforce
moreover have "(matrix_sum d (λn. c ⋅⇩m denote_while_n ?A ?B (denote x2) n ρ)) m = c ⋅⇩m (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ)) m"
using matrix_sum_smult[of m "(λn. denote_while_n (x1 0) (x1 1) (denote x2) n ρ)" d c] dim by auto
ultimately show ?thesis by auto
qed
then have "matrix_seq.lowner_lub (matrix_sum d (λn. denote_while_n (x1 0) (x1 1) (denote x2) n (complex_of_real c ⋅⇩m ρ))) =
matrix_seq.lowner_lub (λn. c ⋅⇩m (matrix_sum d (λn. denote_while_n ?A ?B (denote x2) n ρ)) n)"
by meson
then show ?thesis
unfolding denote_while_def matrix_inf_sum_def using llscale by auto
qed
lemma denote_scale:
fixes c :: real
assumes "c≥0"
shows "well_com S ⟹ ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ ⟹
trace (c ⋅⇩m ρ) ≤ 1 ⟹ denote S (c ⋅⇩m ρ) = c ⋅⇩m denote S ρ"
proof (induction arbitrary: ρ)
case SKIP
then show ?case by auto
next
case (Utrans x)
then show ?case
unfolding denote.simps apply (mat_assoc d) using Utrans by auto
next
case (Seq x1 x2a)
then show ?case
proof -
have cd: "denote x1 (c ⋅⇩m ρ) = c ⋅⇩m denote x1 ρ" using Seq by auto
have x1: "denote x1 ρ ∈ carrier_mat d d ∧ partial_density_operator (denote x1 ρ) ∧ trace (denote x1 ρ) ≤ trace ρ"
using denote_positive_trace_dim Seq denote_partial_density_operator by auto
have "trace (c ⋅⇩m denote x1 ρ) = c * trace (denote x1 ρ)" using trace_smult x1 by auto
also have "… ≤ c * trace ρ" using x1 assms
by (metis Seq.prems cd denote_positive_trace_dim partial_density_operator_def positive_scale smult_carrier_mat trace_smult well_com.simps(3))
also have "… ≤ 1" using Seq(6) trace_smult Seq(4)
by (simp add: trace_smult)
finally have "trace (c ⋅⇩m denote x1 ρ) ≤1" by auto
then have "denote x2a (c ⋅⇩m denote x1 ρ) = c ⋅⇩m denote x2a ( denote x1 ρ)" using x1 Seq by auto
then show ?thesis using denote.simps(4) cd by auto
qed
next
case (Measure x1 x2a x3a)
then show ?case
proof -
have ptc: "⋀x3aa ρ. x3aa ∈ set x3a ⟹ well_com x3aa ⟹ ρ ∈ carrier_mat d d ⟹ partial_density_operator ρ
⟹ positive (denote x3aa ρ) ∧ trace (denote x3aa ρ) ≤ trace ρ ∧ denote x3aa ρ ∈ carrier_mat d d"
using denote_positive_trace_dim Measure by auto
have cad: "x2a k * (c ⋅⇩m ρ) * adjoint (x2a k) = c ⋅⇩m (x2a k * ρ * adjoint (x2a k))"
if k: "k < x1" for k
apply (mat_assoc d) using well_com.simps Measure measurement_dim k by auto
have "∀k<x1. x2a k * ρ * adjoint (x2a k) ∈ carrier_mat d d"
using Measure(2) measurement_dim Measure(3) by fastforce
have lea: "∀k<x1. adjoint (x2a k) * x2a k ≤⇩L 1⇩m d" using measurement_le_one_mat Measure(2) by auto
then have pdox: "∀ k<x1. partial_density_operator (x2a k * ρ * adjoint (x2a k))"
using pdo_close_under_measurement Measure(2,3,4) measurement_dim
by (meson state_sig.well_com.simps(4))
have x2aa:"∀ k < x1. (x2a k * ρ * adjoint (x2a k)) ∈ carrier_mat d d" using Measure(2,3) measurement_dim by fastforce
have dimm: "(⋀k. k < x1 ⟹ (map denote x3a ! k) (x2a k * ρ * adjoint (x2a k)) ∈ carrier_mat d d)"
using map_denote_positive_trace_dim Measure(2,3,4) ptc by auto
then have dimcm: "(⋀k. k < x1 ⟹ c ⋅⇩m (map denote x3a ! k) (x2a k * ρ * adjoint (x2a k)) ∈ carrier_mat d d)"
using smult_carrier_mat by auto
have tra: "∀ k < x1. trace ((x2a k * ρ * adjoint (x2a k))) ≤ trace ρ"
using trace_decrease_mul_adj Measure lea measurement_dim by auto
have tra1: "trace (c ⋅⇩m (x2a k * ρ * adjoint (x2a k))) ≤ 1" if k: "k < x1" for k
proof -
have trle: "trace (x2a k * ρ * adjoint (x2a k)) ≤ trace ρ" using tra k by auto
have "trace (c ⋅⇩m (x2a k * ρ * adjoint (x2a k))) = c * trace ((x2a k * ρ * adjoint (x2a k)))"
using trace_smult x2aa k by auto
also have "… ≤ c * trace ρ"
using trle assms mulfact by auto
also have "… ≤ 1" using Measure(3,5) trace_smult by metis
finally show ?thesis by auto
qed
have "(map denote x3a ! k) (x2a k * (c ⋅⇩m ρ) * adjoint (x2a k))
= c ⋅⇩m (map denote x3a ! k) (x2a k * ρ * adjoint (x2a k))" if k: "k < x1" for k
proof -
have "denote (x3a ! k) (x2a k * (c ⋅⇩m ρ) * adjoint (x2a k)) = denote (x3a ! k) (c ⋅⇩m (x2a k * ρ * adjoint (x2a k)))"
using cad k by auto
also have "… = c ⋅⇩m denote (x3a ! k) ( (x2a k * ρ * adjoint (x2a k)))"
using Measure(1,2) pdox x2aa tra1 k using measure_well_com by auto
finally have "denote (x3a ! k) (x2a k * (complex_of_real c ⋅⇩m ρ) * adjoint (x2a k)) = complex_of_real c ⋅⇩m denote (x3a ! k) (x2a k * ρ * adjoint (x2a k))"
by auto
then show ?thesis using Measure.prems(1) k by auto
qed
then have "matrix_sum d (λk. c ⋅⇩m (map denote x3a ! k) (x2a k * ρ * adjoint (x2a k))) x1 =
matrix_sum d (λk. (map denote x3a ! k) (x2a k * (c ⋅⇩m ρ) * adjoint (x2a k))) x1"
using matrix_sum_cong[of x1 "(λk. complex_of_real c ⋅⇩m (map denote x3a ! k) (x2a k * ρ * adjoint (x2a k)))"
"(λk. (map denote x3a ! k) (x2a k * (complex_of_real c ⋅⇩m ρ) * adjoint (x2a k)))"] dimcm by auto
then have "matrix_sum d (λk. (map denote x3a ! k) (x2a k * (c ⋅⇩m ρ) * adjoint (x2a k))) x1 =
c ⋅⇩m matrix_sum d (λk. (map denote x3a ! k) (x2a k * ρ * adjoint (x2a k))) x1"
using matrix_sum_smult[of x1 "(λk. (map denote x3a ! k) (x2a k * ρ * adjoint (x2a k)))" d c] dimm by auto
then have "denote (Measure x1 x2a x3a) (c ⋅⇩m ρ) = c ⋅⇩m denote (Measure x1 x2a x3a) ρ"
using denote.simps(4)[of x1 x2a x3a "c ⋅⇩m ρ"]
using denote.simps(4)[of x1 x2a x3a "ρ"] unfolding denote_measure_def by auto
then show ?thesis by auto
qed
next
case (While x1 x2a)
then show ?case
apply auto
using denote_while_scale assms by auto
qed
lemma limit_mat_denote_while_n:
assumes wc: "well_com (While M S)" and dr: "ρ ∈ carrier_mat d d" and pdor: "partial_density_operator ρ"
shows "limit_mat (matrix_sum d (λk. denote_while_n (M 0) (M 1) (denote S) k ρ)) (denote (While M S) ρ) d"
proof -
have m: "measurement d 2 M" using wc by auto
then have dM0: "M 0 ∈ carrier_mat d d" and dM1: "M 1 ∈ carrier_mat d d" and id: "adjoint (M 0) * (M 0) + adjoint (M 1) * (M 1) = 1⇩m d"
using measurement_id2 m measurement_def by auto
have wcs: "well_com S" using wc by auto
have DS: "positive (denote S ρ) ∧ trace (denote S ρ) ≤ trace ρ ∧ denote S ρ ∈ carrier_mat d d"
if "ρ ∈ carrier_mat d d" and "partial_density_operator ρ" for ρ
using wcs that denote_positive_trace_dim by auto
have sumdd: "(∀n. matrix_sum d (λn. denote_while_n (M 0) (M 1) (denote S) n ρ) n ∈ carrier_mat d d)"
if "ρ ∈ carrier_mat d d" and "partial_density_operator ρ" for ρ
using denote_while_n_sum_dim dM0 dM1 DS that by auto
have sumtr: "∀ n. trace (matrix_sum d (λn. denote_while_n (M 0) (M 1) (denote S) n ρ) n) ≤ trace ρ"
if "ρ ∈ carrier_mat d d" and "partial_density_operator ρ" for ρ
using denote_while_n_sum_trace[OF dM0 dM1 id DS] that by auto
have sumpar: "(∀n. partial_density_operator (matrix_sum d (λn. denote_while_n (M 0) (M 1) (denote S) n ρ) n))"
if "ρ ∈ carrier_mat d d" and "partial_density_operator ρ" for ρ
using denote_while_n_sum_partial_density[OF dM0 dM1 id DS] that by auto
have sumle:"(∀n. matrix_sum d (λn. denote_while_n (M 0) (M 1) (denote S) n ρ) n ≤⇩L matrix_sum d (λn. denote_while_n (M 0) (M 1) (denote S) n ρ) (Suc n))"
if "ρ ∈ carrier_mat d d" and "partial_density_operator ρ" for ρ
using denote_while_n_sum_lowner_le[OF dM0 dM1 id DS] that by auto
have seqd: "matrix_seq d (matrix_sum d (λn. denote_while_n (M 0) (M 1) (denote S) n ρ))"
if "ρ ∈ carrier_mat d d" and "partial_density_operator ρ" for ρ
using matrix_seq_def sumdd sumpar sumle that by auto
have "matrix_seq.lowner_is_lub (matrix_sum d (λn. denote_while_n (M 0) (M 1) (denote S) n ρ))
(matrix_seq.lowner_lub (matrix_sum d (λn. denote_while_n (M 0) (M 1) (denote S) n ρ)))"
using DS lowner_is_lub_matrix_sum dM0 dM1 id pdor dr by auto
then show "limit_mat (matrix_sum d (λk. denote_while_n (M 0) (M 1) (denote S) k ρ)) (denote (While M S) ρ) d"
unfolding denote.simps denote_while_def matrix_inf_sum_def using matrix_seq.lowner_lub_is_limit[OF seqd[OF dr pdor]] by auto
qed
end
end
Theory Partial_State
section ‹Partial state›
theory Partial_State
imports Quantum_Program Deep_Learning.Tensor_Matricization
begin
lemma nths_intersection_eq:
assumes "{0..<length xs} ⊆ A"
shows "nths xs B = nths xs (A ∩ B)"
proof -
have "⋀x. x ∈ set (zip xs [0..<length xs]) ⟹ snd x < length xs"
by (metis atLeastLessThan_iff atLeastLessThan_upt in_set_zip nth_mem)
then have "⋀x. x ∈ set (zip xs [0..<length xs]) ⟹ snd x ∈ A" using assms by auto
then have eqp: "⋀x. x ∈ set (zip xs [0..<length xs]) ⟹ snd x ∈ B = (snd x ∈ (A ∩ B))" by simp
then have "filter (λp. snd p ∈ B) (zip xs [0..<length xs]) = filter (λp. snd p ∈ (A ∩ B)) (zip xs [0..<length xs])"
using filter_cong[of "(zip xs [0..<length xs])" "(zip xs [0..<length xs])", OF _ eqp] by auto
then show "nths xs B = nths xs (A ∩ B)" unfolding nths_def by auto
qed
lemma nths_minus_eq:
assumes "{0..<length xs} ⊆ A"
shows "nths xs (-B) = nths xs (A - B)"
proof -
have "⋀x. x ∈ set (zip xs [0..<length xs]) ⟹ snd x < length xs"
by (metis atLeastLessThan_iff atLeastLessThan_upt in_set_zip nth_mem)
then have "⋀x. x ∈ set (zip xs [0..<length xs]) ⟹ snd x ∈ A" using assms by auto
then have eqp: "⋀x. x ∈ set (zip xs [0..<length xs]) ⟹ snd x ∈ (-B) = (snd x ∈ (A - B))" by simp
then have "filter (λp. snd p ∈ (-B)) (zip xs [0..<length xs]) = filter (λp. snd p ∈ (A-B)) (zip xs [0..<length xs])"
using filter_cong[of "(zip xs [0..<length xs])" "(zip xs [0..<length xs])", OF _ eqp] by auto
then show "nths xs (-B) = nths xs (A - B)" unfolding nths_def by auto
qed
lemma nths_split_complement_eq:
assumes "A ∩ B = {}"
and "{0..<length xs} ⊆ A ∪ B"
shows "nths xs A = nths xs (-B)"
proof -
have "nths xs (-B) = nths xs (A ∪ B - B)" using nths_minus_eq assms by auto
moreover have "A ∪ B - B = A" using assms by auto
ultimately show ?thesis by auto
qed
lemma lt_set_card_lt:
fixes A :: "nat set"
assumes "finite A" and "x ∈ A"
shows "card {y. y ∈ A ∧ y < x} < card A"
proof -
have "x ∉ {y. y ∈ A ∧ y < x}" by auto
then have "{y. y ∈ A ∧ y < x} ⊆ A - {x}" by auto
then have "card {y. y ∈ A ∧ y < x} ≤ card (A - {x})"
using card_mono finite_Diff[OF assms(1)] by auto
also have "… < card A" using card_Diff1_less[OF assms] by auto
finally show ?thesis by auto
qed
definition ind_in_set where
"ind_in_set A x = card {i. i ∈ A ∧ i < x}"
lemma bij_ind_in_set_bound:
fixes M :: "nat" and v0 :: "nat set"
assumes "⋀x. f x = card {y. y ∈ v0 ∧ y < x}"
shows "bij_betw f ({0..<M} ∩ v0) {0..<card ({0..<M} ∩ v0)}"
unfolding bij_betw_def
proof
let ?dom = "{0..<M} ∩ v0"
let ?ran = "{0..<card ({0..<M} ∩ v0)}"
{
fix x1 x2 :: nat assume x1: "x1 ∈ ?dom" and x2: "x2 ∈ ?dom" and "f x1 = f x2"
then have "card {y. y ∈ v0 ∧ y < x1} = card {y. y ∈ v0 ∧ y < x2}" using assms by auto
then have "pick v0 (card {y. y ∈ v0 ∧ y < x1}) = pick v0 (card {y. y ∈ v0 ∧ y < x2})" by auto
moreover have "pick v0 (card {y. y ∈ v0 ∧ y < x1}) = x1" using pick_card_in_set x1 by auto
moreover have "pick v0 (card {y. y ∈ v0 ∧ y < x2}) = x2" using pick_card_in_set x2 by auto
ultimately have "x1 = x2" by auto
}
then show "inj_on f ?dom" unfolding inj_on_def by auto
{
fix x assume x: "x ∈ ?dom"
then have "(y ∈ v0 ∧ y < x) = (y ∈ ?dom ∧ y < x)" for y using x by auto
then have "card {y. y ∈ v0 ∧ y < x} = card {y. y ∈ ?dom ∧ y < x}" by auto
moreover have "card {y. y ∈ ?dom ∧ y < x} < card ?dom" using x lt_set_card_lt[of ?dom] by auto
ultimately have "f x ∈ ?ran" using assms by auto
}
then have sub: "(f ` ?dom) ⊆ ?ran" by auto
{
fix y assume y: "y ∈ ?ran"
then have yle: "y < card ?dom" by auto
then have pyindom: "pick ?dom y ∈ ?dom" using pick_in_set_le[of y ?dom] by auto
then have "pick ?dom y < M" by auto
then have "⋀z. (z < pick ?dom y ⟹ z ∈ v0 = (z ∈ ?dom))" by auto
then have "{z. z ∈ v0 ∧ z < pick ?dom y} = {z. z ∈ ?dom ∧ z < pick ?dom y}" by auto
then have "card {z. z ∈ v0 ∧ z < pick ?dom y} = card {z. z ∈ ?dom ∧ z < pick ?dom y}" by auto
then have "f (pick ?dom y) = y" using card_pick_le[OF yle] assms by auto
with pyindom have "∃x∈?dom. f x = y" by auto
}
then have sup: "?ran ⊆ (f ` ?dom)" by fastforce
show "(f ` ?dom) = ?ran" using sub sup by auto
qed
lemma ind_in_set_bound:
fixes A :: "nat set" and M N :: "nat"
assumes "N ≥ M"
shows "ind_in_set A N ∉ (ind_in_set A ` ({0..<M} ∩ A))"
proof -
have "{0..<M}∩A ⊆ {i. i ∈ A ∧ i < N}" using assms by auto
then have "card ({0..<M}∩A) ≤ card {i. i ∈ A ∧ i < N}"
using card_mono[of "{i. i ∈ A ∧ i < N}"] by auto
moreover have "ind_in_set A N = card {i. i ∈ A ∧ i < N}" unfolding ind_in_set_def by auto
ultimately have "ind_in_set A N ≥ card ({0..<M}∩A)" by auto
moreover have "y ∈ ind_in_set A ` (A ∩ {0..<M}) ⟹ y < card ({0..<M}∩A)" for y
proof -
let ?dom = "{0..<M} ∩ A"
assume "y ∈ ind_in_set A ` (A ∩ {0..<M})"
then obtain x where x: "x ∈ ?dom" and y: "ind_in_set A x = y" by auto
then have "(y ∈ A ∧ y < x) = (y ∈ ?dom ∧ y < x)" for y using x by auto
then have "card {y. y ∈ A ∧ y < x} = card {y. y ∈ ?dom ∧ y < x}" by auto
moreover have "card {y. y ∈ ?dom ∧ y < x} < card ?dom" using x lt_set_card_lt[of ?dom] by auto
ultimately show "y < card ({0..<M}∩A)" using y unfolding ind_in_set_def by auto
qed
ultimately show ?thesis by fastforce
qed
lemma bij_minus_subset:
"bij_betw f A B ⟹ C ⊆ A ⟹ (f ` A) - (f ` C) = f ` (A - C)"
by (metis Diff_subset bij_betw_imp_inj_on bij_betw_imp_surj_on inj_on_image_set_diff)
lemma ind_in_set_minus_subset_bound:
fixes A B :: "nat set" and M :: "nat"
assumes "B ⊆ A"
shows "(ind_in_set A ` ({0..<M} ∩ A)) - (ind_in_set A ` B) = (ind_in_set A ` ({0..<M} ∩ A)) ∩ (ind_in_set A ` (A - B))"
proof -
let ?dom = "{0..<M} ∩ A"
let ?ran = "{0..<card ({0..<M} ∩ A)}"
let ?f = "ind_in_set A"
let ?C = "A - B"
have bij: "bij_betw ?f ?dom ?ran"
using bij_ind_in_set_bound[of "?f" A M] unfolding ind_in_set_def by auto
then have eq: "?f ` ?dom = ?ran" using bij_betw_imp_surj_on by fastforce
have "(?f ` B) = (?f ` ({0..<M} ∩ B)) ∪ (?f ` ({n. n ≥ M} ∩ B))"
by fastforce
then have "(?f ` ?dom) - (?f ` B)
= (?f ` ?dom) - (?f ` ({n. n ≥ M} ∩ B)) - (?f ` ({0..<M} ∩ B))"
by fastforce
moreover have "(?f ` ({n. n ≥ M} ∩ B)) ∩ (?f ` ?dom) = {}" using ind_in_set_bound[of M _ A] by auto
ultimately have eq1: "(?f ` ?dom) - (?f ` B) = (?f ` ?dom) - (?f ` ({0..<M} ∩ B))" by auto
have "{0..<M} ∩ B ⊆ ?dom" using assms by auto
then have "(?f ` ?dom) - (?f ` ({0..<M} ∩ B)) = ?f ` (?dom - ({0..<M} ∩ B))"
using bij bij_minus_subset[of "?f"] by auto
also have "… = ?f ` ({0..<M} ∩ ?C)" by auto
finally have eq2: "(?f ` ?dom) - (?f ` B) = ?f ` ({0..<M} ∩ ?C)" using eq1 by auto
have "(?f ` ?C) = (?f ` ({0..<M} ∩ ?C)) ∪ (?f ` ({n. n ≥ M} ∩ ?C))" by fastforce
moreover have "(?f ` ({n. n ≥ M} ∩ ?C)) ∩ (?f ` ?dom) = {}" using ind_in_set_bound[of M _ A] by auto
ultimately have eq3:"(ind_in_set A ` ?dom) ∩ (?f ` ?C) = (ind_in_set A ` ?dom) ∩ (?f ` ({0..<M} ∩ ?C))" by auto
have "{0..<M} ∩ ?C ⊆ ?dom" using assms by auto
then have "(ind_in_set A ` ?dom) ∩ (?f ` ({0..<M} ∩ ?C)) = (?f ` ({0..<M} ∩ ?C))" using bij by fastforce
then show ?thesis using eq2 eq3 by auto
qed
lemma ind_in_set_iff:
fixes A B :: "nat set"
assumes "x ∈ A" and "B ⊆ A"
shows "ind_in_set A x ∈ (ind_in_set A ` B) = (x ∈ B)"
proof
have lemm: "card {i. i ∈ A ∧ i < (x::nat) } = card {i. i ∈ A ∧ i < (y::nat) } ⟹ x ∈ A ⟹ y ∈ A ⟹ x = y" for A x y
by (metis (full_types) pick_card_in_set)
{
assume "ind_in_set A x ∈ (ind_in_set A ` B)"
then have "∃y ∈ B. card {i ∈ A. i < x} = card {i ∈ A. i < y}" unfolding ind_in_set_def by auto
then obtain y where y1: "y ∈ B" and ceq: "card {i ∈ A. i < x} = card {i ∈ A. i < y}" by auto
with y1 assms have y0: "y ∈ A" by auto
then have "x = y" using lemm[OF ceq] y0 assms by auto
then show "x ∈ B" using y1 by auto
}
qed (simp add: ind_in_set_def)
lemma nths_reencode_eq:
assumes "B ⊆ A"
shows "nths (nths xs A) (ind_in_set A ` B) = nths xs B"
proof (induction xs rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc x xs)
have seteq: "{i. i < length xs ∧ i ∈ A} = {i. i ∈ A ∧ i < length xs}" by auto
show ?case
proof (cases "length xs ∈ B")
case True
have "nths (xs @ [x]) B = nths xs B @ nths [x] {l. l + length xs ∈ B}" using nths_append[of xs] by auto
moreover have "nths [x] {l. l + length xs ∈ B} = [x]" using nths_singleton True by auto
ultimately have eqT1: "nths (xs @ [x]) B = nths xs B @ [x]" by auto
then have "length xs ∈ A" using True assms by auto
then have "nths [x] {l. l + length xs ∈ A} = [x]" using nths_singleton by auto
moreover have "nths (xs @ [x]) A = nths xs A @ nths [x] {l. l + length xs ∈ A}" using nths_append[of xs] by auto
ultimately have "nths (xs @ [x]) A = nths xs A @ [x]" by auto
then have eqT2: "nths (nths (xs @ [x]) A) (ind_in_set A ` B) = nths (nths xs A @ [x]) (ind_in_set A ` B)" by auto
have eqT3: "nths (nths xs A @ [x]) (ind_in_set A ` B)
= nths xs B @ (nths [x] {l. l + length (nths xs A) ∈ (ind_in_set A ` B)})"
using nths_append[of "nths xs A"] snoc by auto
have "ind_in_set A (length xs) = card {i. i < length xs ∧ i ∈ A}" using ind_in_set_def seteq by auto
moreover have "length (nths xs A) = card {i. i < length xs ∧ i ∈ A}" using length_nths by auto
ultimately have "length (nths xs A) = ind_in_set A (length xs)" by auto
moreover have "ind_in_set A (length xs) ∈ ind_in_set A ` B" using True by auto
ultimately have "length (nths xs A) ∈ ind_in_set A ` B" by auto
then have "(nths [x] {l. l + length (nths xs A) ∈ (ind_in_set A ` B)}) = [x]" using nths_singleton by auto
then have "nths (nths xs A @ [x]) (ind_in_set A ` B) = nths xs B @ [x]" using eqT3 by auto
then show ?thesis using eqT1 eqT2 by auto
next
case False
have "nths (xs @ [x]) B = nths xs B @ nths [x] {l. l + length xs ∈ B}" using nths_append[of xs] by auto
moreover have "nths [x] {l. l + length xs ∈ B} = []" using nths_singleton False by auto
ultimately have eqT1: "nths (xs @ [x]) B = nths xs B" by auto
have "nths (nths (xs @ [x]) A) (ind_in_set A ` B) = nths xs B"
proof (cases "length xs ∈ A")
case True
then have "nths [x] {l. l + length xs ∈ A} = [x]" using nths_singleton by auto
moreover have "nths (xs @ [x]) A = nths xs A @ nths [x] {l. l + length xs ∈ A}" using nths_append[of xs] by auto
ultimately have "nths (xs @ [x]) A = nths xs A @ [x]" by auto
then have "nths (nths (xs @ [x]) A) (ind_in_set A ` B) = nths (nths xs A @ [x]) (ind_in_set A ` B)" by auto
then have eqT2: "nths (nths (xs @ [x]) A) (ind_in_set A ` B)
= nths xs B @ (nths [x] {l. l + length (nths xs A) ∈ (ind_in_set A ` B)})"
using nths_append[of "nths xs A"] snoc by auto
have "length (nths xs A) ∈ (ind_in_set A ` B) ⟹ length xs ∈ B"
proof -
assume "length (nths xs A) ∈ (ind_in_set A ` B)"
moreover have "length (nths xs A) = card {i. i ∈ A ∧ i < length xs}"
using length_nths[of xs] seteq by auto
ultimately have "card {i. i ∈ A ∧ i < length xs} ∈ (ind_in_set A ` B)" unfolding ind_in_set_def by auto
then show "length xs ∈ B" using ind_in_set_iff True assms unfolding ind_in_set_def by auto
qed
then have "length (nths xs A) ∉ (ind_in_set A ` B)" using False by auto
then have "nths [x] {l. l + length (nths xs A) ∈ (ind_in_set A ` B)} = []" using nths_singleton by auto
then show "nths (nths (xs @ [x]) A) (ind_in_set A ` B) = nths xs B" using eqT2 by auto
next
case False
then have "nths [x] {l. l + length xs ∈ A} = []" using nths_singleton by auto
moreover have "nths (xs @ [x]) A = nths xs A @ nths [x] {l. l + length xs ∈ A}" using nths_append[of xs] by auto
ultimately have "nths (xs @ [x]) A = nths xs A" by auto
then show ?thesis using snoc by auto
qed
with eqT1 show ?thesis by auto
qed
qed
lemma nths_reencode_eq_comp:
assumes "B ⊆ A"
shows "nths (nths xs A) (- ind_in_set A ` B) = nths xs (A - B)"
proof (induction xs rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc x xs)
have sub20: "A - B ⊆ A" using assms by auto
have seteq: "{i. i < length xs ∧ i ∈ A} = {i. i ∈ A ∧ i < length xs}" by auto
show ?case
proof (cases "length xs ∈ (A - B)")
case True
have "nths (xs @ [x]) (A - B) = nths xs (A - B) @ nths [x] {l. l + length xs ∈ (A - B)}" using nths_append[of xs] by auto
moreover have "nths [x] {l. l + length xs ∈ (A - B)} = [x]" using nths_singleton True by auto
ultimately have eqT1: "nths (xs @ [x]) (A - B) = nths xs (A - B) @ [x]" by auto
then have "length xs ∈ A" using True sub20 by auto
then have "nths [x] {l. l + length xs ∈ A} = [x]" using nths_singleton by auto
moreover have "nths (xs @ [x]) A = nths xs A @ nths [x] {l. l + length xs ∈ A}" using nths_append[of xs] by auto
ultimately have "nths (xs @ [x]) A = nths xs A @ [x]" by auto
then have "nths (nths (xs @ [x]) A) (- (ind_in_set A) ` B) = nths (nths xs A @ [x]) (- (ind_in_set A) ` B)" by auto
then have eqT2: "nths (nths (xs @ [x]) A) (- (ind_in_set A) ` B)
= nths xs (A - B) @ (nths [x] {l. l + length (nths xs A) ∈ (- (ind_in_set A) ` B)})"
using nths_append[of "nths xs A"] snoc by auto
have "length (nths xs A) ∈ ((ind_in_set A) ` B) ⟹ length xs ∈ B"
proof -
assume "length (nths xs A) ∈ ((ind_in_set A) ` B)"
moreover have "length (nths xs A) = card {i. i ∈ A ∧ i < length xs}"
using length_nths[of xs] seteq by auto
ultimately have "ind_in_set A (length xs) ∈ (ind_in_set A ` B)" unfolding ind_in_set_def by auto
then show "length xs ∈ B" using ind_in_set_iff True assms by auto
qed
moreover have "length xs ∉ B" using True by auto
ultimately have "length (nths xs A) ∈ (- (ind_in_set A) ` B)" by auto
then have "nths [x] {l. l + length (nths xs A) ∈ (- (ind_in_set A) ` B)} = [x]"
using nths_singleton by auto
then have "nths (nths (xs @ [x]) A) (- (ind_in_set A) ` B) = nths xs (A - B) @ [x]" using eqT2 by auto
then show ?thesis using eqT1 by auto
next
case False
have "nths (xs @ [x]) (A - B) = nths xs (A - B) @ nths [x] {l. l + length xs ∈ (A - B)}" using nths_append[of xs] by auto
moreover have "nths [x] {l. l + length xs ∈ (A - B)} = []" using nths_singleton False by auto
ultimately have eqT1: "nths (xs @ [x]) (A - B) = nths xs (A - B)" by auto
have "nths (nths (xs @ [x]) A) (- (ind_in_set A) ` B) = nths xs (A - B)"
proof (cases "length xs ∈ A")
case True
then have True1: "length xs ∈ B" using False by auto
then have "nths [x] {l. l + length xs ∈ A} = [x]" using nths_singleton True by auto
moreover have "nths (xs @ [x]) A = nths xs A @ nths [x] {l. l + length xs ∈ A}" using nths_append[of xs] by auto
ultimately have "nths (xs @ [x]) A = nths xs A @ [x]" by auto
then have "nths (nths (xs @ [x]) A) (- (ind_in_set A) ` B) = nths (nths xs A @ [x]) (- (ind_in_set A) ` B)" by auto
then have eqT2: "nths (nths (xs @ [x]) A) (- (ind_in_set A) ` B)
= nths xs (A - B) @ (nths [x] {l. l + length (nths xs A) ∈ (- (ind_in_set A) ` B)})"
using nths_append[of "nths xs A"] snoc by auto
have "length (nths xs A) ∈ ((ind_in_set A) ` B)"
proof -
have "length (nths xs A) = card {i. i ∈ A ∧ i < length xs}"
using length_nths[of xs] seteq by auto
moreover have "card {i. i ∈ A ∧ i < length xs} ∈ (ind_in_set A ` B)"
unfolding ind_in_set_def using True ind_in_set_iff[of "length xs"] True1 by auto
ultimately show "length (nths xs A) ∈ (ind_in_set A) ` B" by auto
qed
then have "nths [x] {l. l + length (nths xs A) ∈ (- (ind_in_set A) ` B)} = []" using nths_singleton by auto
then show "nths (nths (xs @ [x]) A) (- (ind_in_set A) ` B) = nths xs (A - B)" using eqT2 by auto
next
case False
then have "nths [x] {l. l + length xs ∈ A} = []" using nths_singleton by auto
moreover have "nths (xs @ [x]) A = nths xs A @ nths [x] {l. l + length xs ∈ A}" using nths_append[of xs] by auto
ultimately have "nths (xs @ [x]) A = nths xs A" by auto
then show ?thesis using snoc by auto
qed
with eqT1 show ?thesis by auto
qed
qed
lemma nths_prod_list_split:
fixes A :: "nat set" and xs :: "nat list"
assumes "B ⊆ A"
shows "prod_list (nths xs A) = (prod_list (nths xs B)) * (prod_list (nths xs (A - B)))"
proof (induction xs rule: rev_induct)
case Nil
then show ?case by auto
next
let ?C = "A - B"
case (snoc x xs)
have SA: "nths (xs @ [x]) A = nths xs A @ nths [x] {j. j + length xs ∈ A}" using nths_append[of xs] by auto
have SB: "nths (xs @ [x]) B = nths xs B @ nths [x] {j. j + length xs ∈ B}" using nths_append[of xs] by auto
have SC: "nths (xs @ [x]) ?C = nths xs ?C @ nths [x] {j. j + length xs ∈ ?C}" using nths_append[of xs] by auto
show ?case
proof (cases "length xs ∈ A")
case True
then have "nths (xs @ [x]) A = nths xs A @ [x]" using SA by auto
then have eqA: "prod_list (nths (xs @ [x]) A) = prod_list (nths xs A) * x" by auto
show ?thesis
proof (cases "length xs ∈ B")
case True
then have "nths (xs @ [x]) B = nths xs B @ [x]" using SB by auto
then have eqB: "prod_list (nths (xs @ [x]) B) = prod_list (nths xs B) * x" by auto
have "length xs ∉ ?C" using True assms by auto
then have "nths (xs @ [x]) ?C = nths xs ?C" using SC by auto
then have eqC: "prod_list (nths (xs @ [x]) ?C) = prod_list (nths xs ?C)" by auto
then show ?thesis using snoc eqA eqB eqC by auto
next
case False
then have "nths (xs @ [x]) B = nths xs B" using SB by auto
then have eqB: "prod_list (nths (xs @ [x]) B) = prod_list (nths xs B)" by auto
then have "length xs ∈ ?C" using True False assms by auto
then have "nths (xs @ [x]) ?C = nths xs ?C @ [x]" using SC by auto
then have eqC: "prod_list (nths (xs @ [x]) ?C) = prod_list (nths xs ?C) * x" by auto
then show ?thesis using snoc eqA eqB eqC by auto
qed
next
case False
then have ninB: "length xs ∉ B" and ninC: "length xs ∉ ?C" using assms by auto
have "nths (xs @ [x]) A = nths xs A" using SA False nths_singleton by auto
then have eqA: "prod_list (nths (xs @ [x]) A) = prod_list (nths xs A)" by auto
have "nths (xs @ [x]) B = nths xs B" using SB ninB nths_singleton by auto
then have eqB: "prod_list (nths (xs @ [x]) B) = prod_list (nths xs B)" by auto
have "nths (xs @ [x]) ?C = nths xs ?C" using SC ninC nths_singleton by auto
then have eqC: "prod_list (nths (xs @ [x]) ?C) = prod_list (nths xs ?C)" by auto
then show ?thesis using eqA eqB eqC snoc by auto
qed
qed
subsection ‹Encodings›
lemma digit_encode_take:
"take n (digit_encode ds a) = digit_encode (take n ds) a"
proof (induct n arbitrary: ds a)
case 0
then show ?case by auto
next
case (Suc n)
then show ?case
proof (cases ds)
case Nil
then show ?thesis by auto
next
case (Cons d ds')
then show ?thesis by (auto simp add: Suc)
qed
qed
lemma nths_minus_upt_eq_drop:
"nths l (-{..<n}) = drop n l"
apply (induct l rule: rev_induct)
by (auto simp add: nths_append)
lemma digit_encode_drop:
"drop n (digit_encode ds a) = digit_encode (drop n ds) (a div (prod_list (take n ds)))"
proof (induct n arbitrary: ds a)
case 0
then show ?case by auto
next
case (Suc n)
then show ?case
proof (cases ds)
case Nil
then show ?thesis by auto
next
case (Cons d ds')
then show ?thesis by (auto simp add: Suc div_mult2_eq)
qed
qed
text ‹List of active variables in the partial state›
locale partial_state = state_sig +
fixes vars :: "nat set"
context partial_state
begin
text ‹Dimensions of active variables›
abbreviation avars :: "nat set" where
"avars ≡ {0..<length dims}"
definition dims1 :: "nat list" where
"dims1 = nths dims vars"
definition dims2 :: "nat list" where
"dims2 = nths dims (-vars)"
lemma dims1_alter:
assumes "avars ⊆ A"
shows "dims1 = nths dims (A ∩ vars)"
using nths_intersection_eq assms unfolding dims1_def by auto
lemma dims2_alter:
assumes "avars ⊆ A"
shows "dims2 = nths dims (A-vars)"
using nths_minus_eq assms unfolding dims2_def by auto
text ‹Total dimension for the active variables›
definition d1 :: nat where
"d1 = prod_list dims1"
text ‹Total dimension for the non-active variables›
definition d2 :: nat where
"d2 = prod_list dims2"
text ‹Translating dimension in d to dimension in d1›
definition encode1 :: "nat ⇒ nat" where
"encode1 i = digit_decode dims1 (nths (digit_encode dims i) vars)"
lemma encode1_alter:
assumes "avars ⊆ A"
shows "encode1 i = digit_decode dims1 (nths (digit_encode dims i) (A ∩ vars))"
using length_digit_encode[of dims i] nths_intersection_eq[of "digit_encode dims i" A vars] assms unfolding encode1_def
by (subgoal_tac "nths (digit_encode dims i) (vars) = nths (digit_encode dims i) (A ∩ vars)", auto)
text ‹Translating dimension in d to dimension in d2›
definition encode2 :: "nat ⇒ nat" where
"encode2 i = digit_decode dims2 (nths (digit_encode dims i) (-vars))"
lemma encode2_alter:
assumes "avars ⊆ A"
shows "encode2 i = digit_decode dims2 (nths (digit_encode dims i) (A-vars))"
using length_digit_encode[of dims i] nths_minus_eq[of "digit_encode dims i" A] assms unfolding encode2_def
by (subgoal_tac "nths (digit_encode dims i) (- vars) = nths (digit_encode dims i) (A - vars)", auto)
lemma encode1_lt [simp]:
assumes "i < d"
shows "encode1 i < d1"
unfolding d1_def encode1_def apply (rule digit_decode_lt)
using dims1_def assms d_def digit_encode_valid_index valid_index_nths by auto
lemma encode2_lt [simp]:
assumes "i < d"
shows "encode2 i < d2"
unfolding d2_def encode2_def apply (rule digit_decode_lt)
using dims2_def assms d_def digit_encode_valid_index valid_index_nths by auto
text ‹Given dimensions in d1 and d2, form dimension in d›
fun encode12 :: "nat × nat ⇒ nat" where
"encode12 (i, j) = digit_decode dims (weave vars (digit_encode dims1 i) (digit_encode dims2 j))"
declare encode12.simps [simp del]
lemma encode12_inv:
assumes "k < d"
shows "encode12 (encode1 k, encode2 k) = k"
unfolding encode12.simps encode1_def encode2_def
using assms d_def digit_encode_valid_index dims1_def dims2_def valid_index_nths by auto
lemma encode12_inv1:
assumes "i < d1" "j < d2"
shows "encode1 (encode12 (i, j)) = i"
unfolding encode12.simps encode1_def
using assms unfolding d1_def d2_def dims1_def dims2_def
by (metis digit_decode_encode_lt digit_encode_decode digit_encode_valid_index valid_index_weave(1,2))
lemma encode12_inv2:
assumes "i < d1" "j < d2"
shows "encode2 (encode12 (i, j)) = j"
unfolding encode12.simps encode2_def
using assms unfolding d1_def d2_def dims1_def dims2_def
by (metis digit_decode_encode_lt digit_encode_decode digit_encode_valid_index valid_index_weave(1,3))
lemma encode12_lt:
assumes "i < d1" "j < d2"
shows "encode12 (i, j) < d"
using assms unfolding encode12.simps d_def d1_def d2_def dims1_def dims2_def
by (simp add: digit_decode_lt digit_encode_valid_index valid_index_weave(1))
lemma sum_encode: "(∑i = 0..<d1. ∑j = 0..<d2. f i j) = sum (λk. f (encode1 k) (encode2 k)) {0..<d}"
apply (subst sum.cartesian_product)
apply (rule sum.reindex_bij_witness[where i="λk. (encode1 k, encode2 k)" and j=encode12])
by (auto simp: encode12_inv1 encode12_inv2 encode12_inv encode12_lt)
subsection ‹Tensor product of vectors and matrices›
text ‹Given vector v1 of dimension d1, and vector v2 of dimension d2, form
the tensor vector of dimension d1 * d2 = d›
definition tensor_vec :: "'a::times vec ⇒ 'a vec ⇒ 'a vec" where
"tensor_vec v1 v2 = Matrix.vec d (λi. v1 $ encode1 i * v2 $ encode2 i)"
lemma tensor_vec_dim [simp]:
"dim_vec (tensor_vec v1 v2) = d"
unfolding tensor_vec_def by auto
lemma tensor_vec_carrier:
"tensor_vec v1 v2 ∈ carrier_vec d"
unfolding tensor_vec_def by auto
lemma tensor_vec_eval:
assumes "i < d"
shows "tensor_vec v1 v2 $ i = v1 $ encode1 i * v2 $ encode2 i"
unfolding tensor_vec_def using assms by simp
lemma tensor_vec_add1:
fixes v1 v2 v3 :: "'a::comm_ring vec"
assumes "v1 ∈ carrier_vec d1"
and "v2 ∈ carrier_vec d1"
and "v3 ∈ carrier_vec d2"
shows "tensor_vec (v1 + v2) v3 = tensor_vec v1 v3 + tensor_vec v2 v3"
apply (rule eq_vecI, auto)
unfolding tensor_vec_eval
using assms(2) comm_semiring_class.distrib by force
lemma tensor_vec_add2:
fixes v1 v2 v3 :: "'a::comm_ring vec"
assumes "v1 ∈ carrier_vec d1"
and "v2 ∈ carrier_vec d2"
and "v3 ∈ carrier_vec d2"
shows "tensor_vec v1 (v2 + v3) = tensor_vec v1 v2 + tensor_vec v1 v3"
apply (rule eq_vecI, auto)
unfolding tensor_vec_eval
using assms(3) semiring_class.distrib_left by force
text ‹Given d1-by-d1 matrix m1, and d2-by-d2 matrix m2, form d-by-d matrix›
definition tensor_mat :: "'a::comm_ring_1 mat ⇒ 'a mat ⇒ 'a mat" where
"tensor_mat m1 m2 = Matrix.mat d d (λ(i,j).
m1 $$ (encode1 i, encode1 j) * m2 $$ (encode2 i, encode2 j))"
lemma tensor_mat_dim_row [simp]:
"dim_row (tensor_mat m1 m2) = d"
unfolding tensor_mat_def by auto
lemma tensor_mat_dim_col [simp]:
"dim_col (tensor_mat m1 m2) = d"
unfolding tensor_mat_def by auto
lemma tensor_mat_carrier:
"tensor_mat m1 m2 ∈ carrier_mat d d"
unfolding tensor_mat_def by auto
lemma tensor_mat_eval:
assumes "i < d" "j < d"
shows "tensor_mat m1 m2 $$ (i, j) = m1 $$ (encode1 i, encode1 j) * m2 $$ (encode2 i, encode2 j)"
unfolding tensor_mat_def using assms by simp
lemma tensor_mat_zero1:
shows "tensor_mat (0⇩m d1 d1) m1 = 0⇩m d d"
apply (rule eq_matI)
by (auto simp add: tensor_mat_eval)
lemma tensor_mat_zero2:
shows "tensor_mat m1 (0⇩m d2 d2) = 0⇩m d d"
apply (rule eq_matI)
by (auto simp add: tensor_mat_eval)
lemma tensor_mat_add1:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d1 d1"
and "m3 ∈ carrier_mat d2 d2"
shows "tensor_mat (m1 + m2) m3 = tensor_mat m1 m3 + tensor_mat m2 m3"
apply (rule eq_matI, auto)
unfolding tensor_mat_eval
using assms(2) comm_semiring_class.distrib by force
lemma tensor_mat_add2:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d2 d2"
and "m3 ∈ carrier_mat d2 d2"
shows "tensor_mat m1 (m2 + m3) = tensor_mat m1 m2 + tensor_mat m1 m3"
apply (rule eq_matI, auto)
unfolding tensor_mat_eval
using assms(3) semiring_class.distrib_left by force
lemma tensor_mat_minus1:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d1 d1"
and "m3 ∈ carrier_mat d2 d2"
shows "tensor_mat (m1 - m2) m3 = tensor_mat m1 m3 - tensor_mat m2 m3"
apply (rule eq_matI, auto)
unfolding tensor_mat_eval
apply (subst index_minus_mat)
subgoal using assms by auto
subgoal using assms by auto
using assms(2) ring_class.left_diff_distrib by force
lemma tensor_mat_matrix_sum2:
assumes "m1 ∈ carrier_mat d1 d1"
shows "(⋀k. k < n ⟹ f k ∈ carrier_mat d2 d2)
⟹ matrix_sum d (λk. tensor_mat m1 (f k)) n = tensor_mat m1 (matrix_sum d2 f n)"
proof (induct n)
case 0
then show ?case apply simp using tensor_mat_zero2[of m1] by auto
next
case (Suc n)
then have "k < n ⟹ f k ∈ carrier_mat d2 d2" for k by auto
then have ds: "matrix_sum d2 f n ∈ carrier_mat d2 d2" using matrix_sum_dim by auto
have dn: "f n ∈ carrier_mat d2 d2" using Suc by auto
have "matrix_sum d2 f (Suc n) = f n + matrix_sum d2 f n" by simp
then have eq: "tensor_mat m1 (matrix_sum d2 f (Suc n))
= tensor_mat m1 (f n) + tensor_mat m1 (matrix_sum d2 f n)"
using tensor_mat_add2 dn ds assms by auto
have "matrix_sum d (λk. tensor_mat m1 (f k)) (Suc n)
= tensor_mat m1 (f n) + matrix_sum d (λk. tensor_mat m1 (f k)) n" by simp
also have "… = tensor_mat m1 (f n) + tensor_mat m1 (matrix_sum d2 f n)"
using Suc by auto
finally show ?case using eq by auto
qed
lemma tensor_mat_scale1:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d2 d2"
shows "tensor_mat (a ⋅⇩m m1) m2 = a ⋅⇩m tensor_mat m1 m2"
apply (rule eq_matI, auto)
unfolding tensor_mat_eval
using assms comm_semiring_class.distrib by force
lemma tensor_mat_scale2:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d2 d2"
shows "tensor_mat m1 (a ⋅⇩m m2) = a ⋅⇩m tensor_mat m1 m2"
apply (rule eq_matI, auto)
unfolding tensor_mat_eval
using assms comm_semiring_class.distrib by force
lemma tensor_mat_trace:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d2 d2"
shows "trace (tensor_mat m1 m2) = trace m1 * trace m2"
apply (auto simp add: tensor_mat_carrier trace_def tensor_mat_eval)
apply (subst Groups_Big.sum_product)
apply (subst sum_encode[symmetric])
using assms by auto
lemma tensor_mat_id:
"tensor_mat (1⇩m d1) (1⇩m d2) = 1⇩m d"
proof (rule eq_matI, auto)
show "tensor_mat (1⇩m d1) (1⇩m d2) $$ (i, i) = 1" if "i < d" for i
using that by (simp add: tensor_mat_eval)
next
show "tensor_mat (1⇩m d1) (1⇩m d2) $$ (i, j) = 0" if "i < d" "j < d" "i ≠ j" for i j
using that apply (simp add: tensor_mat_eval)
by (metis encode12_inv)
qed
lemma tensor_mat_mult_vec:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d2 d2"
and "v1 ∈ carrier_vec d1"
and "v2 ∈ carrier_vec d2"
shows "tensor_vec (m1 *⇩v v1) (m2 *⇩v v2) = tensor_mat m1 m2 *⇩v tensor_vec v1 v2"
proof (rule eq_vecI, auto)
fix i j :: nat
assume i: "i < d"
let ?i1 = "encode1 i" and ?i2 = "encode2 i"
have "tensor_vec (m1 *⇩v v1) (m2 *⇩v v2) $ i = (m1 *⇩v v1) $ ?i1 * (m2 *⇩v v2) $ ?i2"
using i by (simp add: tensor_vec_eval)
also have "… = (row m1 ?i1 ∙ v1) * (row m2 ?i2 ∙ v2)"
using assms i by auto
also have "… = (∑i = 0..<d1. m1 $$ (?i1, i) * v1 $ i) * (∑j = 0..<d2. m2 $$ (?i2, j) * v2 $ j)"
using assms i by (simp add: scalar_prod_def)
also have "… = (∑i = 0..<d1. ∑j = 0..<d2. (m1 $$ (?i1, i) * v1 $ i) * (m2 $$ (?i2, j) * v2 $ j))"
by (rule Groups_Big.sum_product)
also have "… = (∑i = 0..<d. (m1 $$ (?i1, encode1 i) * v1 $ (encode1 i)) * (m2 $$ (?i2, encode2 i) * v2 $ (encode2 i)))"
by (rule sum_encode)
also have "… = row (tensor_mat m1 m2) i ∙ tensor_vec v1 v2"
apply (simp add: scalar_prod_def tensor_mat_eval tensor_vec_eval i)
by (rule sum.cong, auto)
finally show "tensor_vec (m1 *⇩v v1) (m2 *⇩v v2) $ i = row (tensor_mat m1 m2) i ∙ tensor_vec v1 v2" by auto
qed
lemma tensor_mat_mult:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d1 d1"
and "m3 ∈ carrier_mat d2 d2"
and "m4 ∈ carrier_mat d2 d2"
shows "tensor_mat (m1 * m2) (m3 * m4) = tensor_mat m1 m3 * tensor_mat m2 m4"
proof (rule eq_matI, auto)
fix i j :: nat
assume i: "i < d" and j: "j < d"
let ?i1 = "encode1 i" and ?i2 = "encode2 i" and ?j1 = "encode1 j" and ?j2 = "encode2 j"
have "tensor_mat (m1 * m2) (m3 * m4) $$ (i, j) = (m1 * m2) $$ (?i1, ?j1) * (m3 * m4) $$ (?i2, ?j2)"
using i j by (simp add: tensor_mat_eval)
also have "… = (row m1 ?i1 ∙ col m2 ?j1) * (row m3 ?i2 ∙ col m4 ?j2)"
using assms i j by auto
also have "… = (∑i = 0..<d1. m1 $$ (?i1, i) * m2 $$ (i, ?j1)) * (∑j = 0..<d2. m3 $$ (?i2, j) * m4 $$ (j, ?j2))"
using assms i j by (simp add: scalar_prod_def)
also have "… = (∑i = 0..<d1. ∑j = 0..<d2. (m1 $$ (?i1, i) * m2 $$ (i, ?j1)) * (m3 $$ (?i2, j) * m4 $$ (j, ?j2)))"
by (rule Groups_Big.sum_product)
also have "… = (∑i = 0..<d. (m1 $$ (?i1, encode1 i) * m2 $$ (encode1 i, ?j1)) * (m3 $$ (?i2, encode2 i) * m4 $$ (encode2 i, ?j2)))"
by (rule sum_encode)
also have "… = row (tensor_mat m1 m3) i ∙ col (tensor_mat m2 m4) j"
apply (simp add: scalar_prod_def tensor_mat_eval i j)
by (rule sum.cong, auto)
finally show "tensor_mat (m1 * m2) (m3 * m4) $$ (i, j) = row (tensor_mat m1 m3) i ∙ col (tensor_mat m2 m4) j" .
qed
lemma tensor_mat_adjoint:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d2 d2"
shows "adjoint (tensor_mat m1 m2) = tensor_mat (adjoint m1) (adjoint m2)"
apply (rule eq_matI, auto)
unfolding tensor_mat_def adjoint_def
using assms by (simp add: conjugate_dist_mul)
lemma tensor_mat_hermitian:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d2 d2"
and "hermitian m1"
and "hermitian m2"
shows "hermitian (tensor_mat m1 m2)"
using assms by (metis hermitian_def tensor_mat_adjoint)
lemma tensor_mat_unitary:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d2 d2"
and "unitary m1"
and "unitary m2"
shows "unitary (tensor_mat m1 m2)"
using assms apply (auto simp add: unitary_def tensor_mat_adjoint)
using assms unfolding inverts_mat_def
apply (subst tensor_mat_mult[symmetric], auto)
by (rule tensor_mat_id)
lemma tensor_mat_positive:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d2 d2"
and "positive m1"
and "positive m2"
shows "positive (tensor_mat m1 m2)"
proof -
obtain M1 where M1: "m1 = M1 * adjoint M1" and dM1:"M1 ∈ carrier_mat d1 d1" using positive_only_if_decomp assms by auto
obtain M2 where M2: "m2 = M2 * adjoint M2" and dM2:"M2 ∈ carrier_mat d2 d2" using positive_only_if_decomp assms by auto
have "(adjoint (tensor_mat M1 M2)) = tensor_mat (adjoint M1) (adjoint M2)" using tensor_mat_adjoint dM1 dM2 by auto
then have "tensor_mat M1 M2 * (adjoint (tensor_mat M1 M2)) = tensor_mat (M1 * adjoint M1) (M2 * adjoint M2)"
using dM1 dM2 adjoint_dim[OF dM1] adjoint_dim[OF dM2] by (auto simp add: tensor_mat_mult)
also have "… = tensor_mat m1 m2" using M1 M2 by auto
finally have "tensor_mat m1 m2 = tensor_mat M1 M2 * (adjoint (tensor_mat M1 M2))"..
then have "∃M. M * adjoint M = tensor_mat m1 m2" by auto
moreover have "tensor_mat m1 m2 ∈ carrier_mat d d" using tensor_mat_carrier by auto
ultimately show ?thesis using positive_if_decomp[of "tensor_mat m1 m2"] by auto
qed
lemma tensor_mat_positive_le:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d2 d2"
and "positive m1"
and "positive m2"
and "m1 ≤⇩L A"
and "m2 ≤⇩L B"
shows "tensor_mat m1 m2 ≤⇩L tensor_mat A B"
proof -
have dA: "A ∈ carrier_mat d1 d1" using assms lowner_le_def by auto
have pA: "positive A" using assms dA lowner_le_trans_positiveI[of m1] by auto
have dB: "B ∈ carrier_mat d2 d2" using assms lowner_le_def by auto
have pB: "positive B" using assms dB lowner_le_trans_positiveI[of m2] by auto
have "A - m1 = A + (- m1)" using assms by (auto simp add: minus_add_uminus_mat)
then have "positive (A + (- m1))" using assms unfolding lowner_le_def by auto
then have p1: "positive (tensor_mat (A + (- m1)) m2)" using assms tensor_mat_positive by auto
moreover have "tensor_mat (- m1) m2 = - tensor_mat m1 m2" using assms apply (subgoal_tac "- m1 = -1 ⋅⇩m m1")
by (auto simp add: tensor_mat_scale1)
moreover have "tensor_mat (A + (- m1)) m2 = tensor_mat A m2 + (tensor_mat (- m1) m2)" using
assms by (auto simp add: tensor_mat_add1 dA)
ultimately have "tensor_mat (A + (- m1)) m2 = tensor_mat A m2 - (tensor_mat m1 m2)" by auto
with p1 have le1: "tensor_mat m1 m2 ≤⇩L tensor_mat A m2" unfolding lowner_le_def by auto
have "B - m2 = B + (- m2)" using assms by (auto simp add: minus_add_uminus_mat)
then have "positive (B + (- m2))" using assms unfolding lowner_le_def by auto
then have p2: "positive (tensor_mat A (B + (- m2)))"
using assms tensor_mat_positive positive_one dA dB pA by auto
moreover have "tensor_mat A (-m2) = - tensor_mat A m2"
using assms apply (subgoal_tac "- m2 = -1 ⋅⇩m m2")
by (auto simp add: tensor_mat_scale2 dA)
moreover have "tensor_mat A (B + (- m2)) = tensor_mat A B + tensor_mat A (- m2)"
using assms by (auto simp add: tensor_mat_add2 dA dB)
ultimately have "tensor_mat A (B + (- m2)) = tensor_mat A B - tensor_mat A m2" by auto
with p2 have le20: "tensor_mat A m2 ≤⇩L tensor_mat A B" unfolding lowner_le_def by auto
show ?thesis apply (subst lowner_le_trans[of _ d "tensor_mat (A) m2"])
subgoal using tensor_mat_carrier by auto
subgoal using tensor_mat_carrier by auto
using le1 le20 by auto
qed
lemma tensor_mat_le_one:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d2 d2"
and "positive m1"
and "positive m2"
and "m1 ≤⇩L 1⇩m d1"
and "m2 ≤⇩L 1⇩m d2"
shows "tensor_mat m1 m2 ≤⇩L 1⇩m d"
proof -
have "1⇩m d1 - m1 = 1⇩m d1 + (- m1)" using assms by (auto simp add: minus_add_uminus_mat)
then have "positive (1⇩m d1 + (- m1))" using assms unfolding lowner_le_def by auto
then have p1: "positive (tensor_mat (1⇩m d1 + (- m1)) m2)" using assms tensor_mat_positive by auto
moreover have "tensor_mat (- m1) m2 = - tensor_mat m1 m2" using assms apply (subgoal_tac "- m1 = -1 ⋅⇩m m1")
by (auto simp add: tensor_mat_scale1)
moreover have "tensor_mat (1⇩m d1 + (- m1)) m2 = tensor_mat (1⇩m d1) m2 + (tensor_mat (- m1) m2)" using
assms by (auto simp add: tensor_mat_add1)
ultimately have "tensor_mat (1⇩m d1 + (- m1)) m2 = tensor_mat (1⇩m d1) m2 - (tensor_mat m1 m2)" by auto
with p1 have le1: "(tensor_mat m1 m2) ≤⇩L tensor_mat (1⇩m d1) m2" unfolding lowner_le_def by auto
have "1⇩m d2 - m2 = 1⇩m d2 + (- m2)" using assms by (auto simp add: minus_add_uminus_mat)
then have "positive (1⇩m d2 + (- m2))" using assms unfolding lowner_le_def by auto
then have p2: "positive (tensor_mat (1⇩m d1) (1⇩m d2 + (- m2)))" using assms tensor_mat_positive positive_one by auto
moreover have "tensor_mat (1⇩m d1) (-m2) = - tensor_mat (1⇩m d1) m2" using assms apply (subgoal_tac "- m2 = -1 ⋅⇩m m2")
by (auto simp add: tensor_mat_scale2)
moreover have "tensor_mat (1⇩m d1) (1⇩m d2 + (- m2)) = tensor_mat (1⇩m d1) (1⇩m d2) + (tensor_mat (1⇩m d1) (- m2))" using
assms by (auto simp add: tensor_mat_add2)
ultimately have "tensor_mat (1⇩m d1) (1⇩m d2 + (- m2)) = tensor_mat (1⇩m d1) (1⇩m d2) - (tensor_mat (1⇩m d1) m2)" by auto
with p2 have le20: "tensor_mat (1⇩m d1) m2 ≤⇩L tensor_mat (1⇩m d1) (1⇩m d2)" unfolding lowner_le_def by auto
then have le2: "tensor_mat (1⇩m d1) m2 ≤⇩L 1⇩m d" apply (subst tensor_mat_id[symmetric]) by auto
have "tensor_mat (1⇩m d1) (1⇩m d2) = 1⇩m d" using tensor_mat_id by auto
show ?thesis apply (subst lowner_le_trans[of _ d "tensor_mat (1⇩m d1) m2"])
subgoal using tensor_mat_carrier by auto
subgoal using tensor_mat_carrier by auto
using le1 le2 by auto
qed
subsection ‹Extension of matrices›
definition mat_extension :: "'a::comm_ring_1 mat ⇒ 'a mat" where
"mat_extension m = tensor_mat m (1⇩m d2)"
lemma mat_extension_carrier:
"mat_extension m ∈ carrier_mat d d"
by (simp add: mat_extension_def tensor_mat_carrier)
lemma mat_extension_add:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d1 d1"
shows "mat_extension (m1 + m2) = mat_extension m1 + mat_extension m2"
using assms by (simp add: mat_extension_def tensor_mat_add1)
lemma mat_extension_trace:
assumes "m ∈ carrier_mat d1 d1"
shows "trace (mat_extension m) = d2 * trace m"
unfolding mat_extension_def
using assms by (simp add: tensor_mat_trace)
lemma mat_extension_id:
"mat_extension (1⇩m d1) = 1⇩m d"
unfolding mat_extension_def by (rule tensor_mat_id)
lemma mat_extension_mult:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d1 d1"
shows "mat_extension (m1 * m2) = mat_extension m1 * mat_extension m2"
using assms by (simp add: mat_extension_def tensor_mat_mult[symmetric])
lemma mat_extension_hermitian:
assumes "m ∈ carrier_mat d1 d1"
and "hermitian m"
shows "hermitian (mat_extension m)"
using assms by (simp add: hermitian_one mat_extension_def tensor_mat_hermitian)
lemma mat_extension_unitary:
assumes "m ∈ carrier_mat d1 d1"
and "unitary m"
shows "unitary (mat_extension m)"
using assms by (simp add: mat_extension_def tensor_mat_unitary unitary_one)
end
abbreviation "tensor_mat ≡ partial_state.tensor_mat"
abbreviation "mat_extension ≡ partial_state.mat_extension"
context state_sig
begin
text ‹Swapping the order of matrices, as well as switching vars, should have no effect›
lemma tensor_mat_comm:
assumes "vars1 ∩ vars2 = {}"
and "{0..<length dims} ⊆ vars1 ∪ vars2"
and "m1 ∈ carrier_mat (prod_list (nths dims vars1)) (prod_list (nths dims vars1))"
and "m2 ∈ carrier_mat (prod_list (nths dims vars2)) (prod_list (nths dims vars2))"
shows "tensor_mat dims vars1 m1 m2 = tensor_mat dims vars2 m2 m1"
proof -
{
fix i
have "nths dims (- vars2) = nths dims vars1" using nths_split_complement_eq[symmetric] assms by auto
then have eq2211: "partial_state.dims2 dims vars2 = partial_state.dims1 dims vars1"
unfolding partial_state.dims2_def partial_state.dims1_def by auto
have "nths dims (- vars1) = nths dims vars2" using nths_split_complement_eq[symmetric, of vars2] assms by auto
then have eq2112: "partial_state.dims2 dims vars1 = partial_state.dims1 dims vars2"
unfolding partial_state.dims2_def partial_state.dims1_def by auto
have "vars1 ∪ vars2 - vars2 = vars1" using assms by auto
then have e1:"partial_state.encode2 dims vars2 i = partial_state.encode1 dims (vars1) i"
using assms(2) partial_state.encode2_alter[of dims "vars1 ∪ vars2" vars2]
unfolding partial_state.encode2_def partial_state.encode1_def apply (subst eq2211[symmetric]) by auto
have "vars1 ∪ vars2 - vars1 = vars2" using assms by auto
then have e2:"partial_state.encode2 dims vars1 i = partial_state.encode1 dims (vars2) i"
using assms(2) partial_state.encode2_alter[of dims "vars1 ∪ vars2" vars1]
unfolding partial_state.encode2_def partial_state.encode1_def apply (subst eq2112[symmetric]) by auto
note e1 e2
}
note e = this
show ?thesis
unfolding partial_state.tensor_mat_def apply (rule cong_mat, simp_all)
unfolding partial_state.dims1_def partial_state.dims2_def
using e by auto
qed
end
subsection ‹Partial tensor product›
text ‹In this context, we assume two disjoint sets of variables, and define
the tensor product of two matrices on these variables›
locale partial_state2 = state_sig +
fixes vars1 :: "nat set"
and vars2 :: "nat set"
assumes disjoint: "vars1 ∩ vars2 = {}"
begin
definition vars0 :: "nat set" where
"vars0 = vars1 ∪ vars2"
definition dims0 :: "nat list" where
"dims0 = nths dims vars0"
definition dims1 :: "nat list" where
"dims1 = nths dims vars1"
definition dims2 :: "nat list" where
"dims2 = nths dims vars2"
definition d0 :: nat where
"d0 = prod_list dims0"
definition d1 :: nat where
"d1 = prod_list dims1"
definition d2 :: nat where
"d2 = prod_list dims2"
lemma dims_product:
"d0 = d1 * d2"
unfolding d0_def d1_def d2_def dims0_def dims1_def dims2_def vars0_def
using disjoint nths_prod_list_split[of vars1 "vars1 ∪ vars2" dims]
apply (subgoal_tac "vars1 ∪ vars2 - vars1 = vars2")
by auto
text ‹Locations of variables in vars1 relative to vars0.
For example: if vars0 = {0,1,2,4,5,6,9} and vars1 = {1,4,6,9}, then
vars1' should be {1,3,5,6}.›
definition vars1' :: "nat set" where
"vars1' = (ind_in_set vars0) ` vars1"
definition vars2' :: "nat set" where
"vars2' = (ind_in_set vars0) ` vars2"
lemma vars1'I:
"x ∈ vars1 ⟹ card {y∈vars0. y < x} ∈ vars1'"
unfolding vars1'_def ind_in_set_def by auto
lemma vars1'D:
"i ∈ vars1' ⟹ ∃x∈vars1. card {y∈vars0. y < x} = i"
unfolding vars1'_def ind_in_set_def by auto
text ‹Main property of vars1'›
lemma ind_in_set_bij:
"bij_betw (ind_in_set vars0) ({0..<length dims} ∩ vars0) {0..<card ({0..<length dims} ∩ vars0)}"
using bij_ind_in_set_bound unfolding ind_in_set_def by auto
lemma length_dims0:
"length dims0 = card ({0..<length dims} ∩ vars0)"
unfolding dims0_def using length_nths[of dims vars0]
apply (subgoal_tac "{i. i < length dims ∧ i ∈ vars0}= {0..<length dims} ∩ vars0")
by auto
lemma length_dims0_minus_vars2'_is_vars1':
"{0..<length dims0} - vars2' = {0..<length dims0} ∩ vars1'"
proof -
have sub20: "vars2 ⊆ vars0" unfolding vars0_def by auto
have sub1: "vars1 = vars0 - vars2" unfolding vars0_def using disjoint by auto
have eq: "{0..<length dims0} = ind_in_set vars0 ` ({0..<length dims} ∩ vars0)"
using ind_in_set_bij length_dims0 bij_betw_imp_surj_on[of "ind_in_set vars0"] by auto
show ?thesis unfolding vars2'_def vars1'_def eq using ind_in_set_minus_subset_bound[OF sub20] sub1 by auto
qed
lemma length_dims0_minus_vars1'_is_vars2':
"{0..<length dims0} - vars1' = {0..<length dims0} ∩ vars2'"
proof -
have sub10: "vars1 ⊆ vars0" unfolding vars0_def by auto
have sub2: "vars2 = vars0 - vars1" unfolding vars0_def using disjoint by auto
have eq: "{0..<length dims0} = ind_in_set vars0 ` ({0..<length dims} ∩ vars0)"
using ind_in_set_bij length_dims0 bij_betw_imp_surj_on[of "ind_in_set vars0"] by auto
show ?thesis unfolding vars2'_def vars1'_def eq using ind_in_set_minus_subset_bound[OF sub10] sub2 by auto
qed
lemma nths_vars1':
"nths dims0 vars1' = dims1"
using nths_reencode_eq[of vars1 vars0 dims]
using nths_reencode_eq_comp[of vars1 vars0 dims]
unfolding vars0_def ind_in_set_def vars1'_def dims1_def dims0_def by auto
lemma nths_vars1'_comp:
"nths dims0 (-vars2') = dims1"
using nths_reencode_eq_comp[of vars2 vars0 dims] disjoint
unfolding vars0_def ind_in_set_def vars2'_def dims1_def dims0_def
apply (subgoal_tac "(vars1 ∪ vars2 - vars2) = vars1") by auto
lemma nths_vars2':
"nths dims0 (-vars1') = dims2"
using nths_reencode_eq_comp[of vars1 vars0 dims] disjoint
unfolding vars0_def ind_in_set_def vars1'_def dims2_def dims0_def
apply (subgoal_tac "(vars1 ∪ vars2 - vars1) = vars2") by auto
lemma nths_vars2'_comp:
"nths dims0 (vars2') = dims2"
using nths_reencode_eq[of vars2 vars0 dims]
unfolding vars0_def ind_in_set_def vars2'_def dims2_def dims0_def
by auto
lemma ptensor_encode1_encode2:
"partial_state.encode1 dims0 vars1' = partial_state.encode2 dims0 vars2'"
proof -
have "partial_state.encode1 dims0 vars1' i
= digit_decode (partial_state.dims1 dims0 vars1') (nths (digit_encode dims0 i) ({0..<length dims0} ∩ vars1'))" for i
using partial_state.encode1_alter by auto
moreover have "partial_state.encode2 dims0 vars2' i
= digit_decode (partial_state.dims2 dims0 vars2') (nths (digit_encode dims0 i) ({0..<length dims0} - vars2'))" for i
using partial_state.encode2_alter by auto
moreover have "partial_state.dims1 dims0 vars1' = partial_state.dims2 dims0 vars2'"
unfolding partial_state.dims1_def partial_state.dims2_def using nths_vars1' nths_vars1'_comp by auto
ultimately show ?thesis using length_dims0_minus_vars2'_is_vars1' by auto
qed
lemma ptensor_encode2_encode1:
"partial_state.encode1 dims0 vars2' = partial_state.encode2 dims0 vars1'"
proof -
have "partial_state.encode1 dims0 vars2' i
= digit_decode (partial_state.dims1 dims0 vars2') (nths (digit_encode dims0 i) ({0..<length dims0} ∩ vars2'))" for i
using partial_state.encode1_alter by auto
moreover have "partial_state.encode2 dims0 vars1' i
= digit_decode (partial_state.dims2 dims0 vars1') (nths (digit_encode dims0 i) ({0..<length dims0} - vars1'))" for i
using partial_state.encode2_alter by auto
moreover have "partial_state.dims1 dims0 vars2' = partial_state.dims2 dims0 vars1'"
unfolding partial_state.dims1_def partial_state.dims2_def using nths_vars2' nths_vars2'_comp by auto
ultimately show ?thesis using length_dims0_minus_vars1'_is_vars2' by auto
qed
text ‹Given vector v1 of dimension d1, and vector v2 of dimension d2, form
the tensor vector of dimension d1 * d2 = d0›
definition ptensor_vec :: "'a::times vec ⇒ 'a vec ⇒ 'a vec" where
"ptensor_vec v1 v2 = partial_state.tensor_vec dims0 vars1' v1 v2"
lemma ptensor_vec_dim [simp]:
"dim_vec (ptensor_vec v1 v2) = d0"
by (simp add: ptensor_vec_def partial_state.tensor_vec_dim state_sig.d_def d0_def)
lemma ptensor_vec_carrier:
"ptensor_vec v1 v2 ∈ carrier_vec d0"
by (simp add: carrier_dim_vec)
lemma ptensor_vec_add:
fixes v1 v2 v3 :: "'a::comm_ring vec"
assumes "v1 ∈ carrier_vec d1"
and "v2 ∈ carrier_vec d1"
and "v3 ∈ carrier_vec d2"
shows "ptensor_vec (v1 + v2) v3 = ptensor_vec v1 v3 + ptensor_vec v2 v3"
unfolding ptensor_vec_def
apply (rule partial_state.tensor_vec_add1)
unfolding partial_state.d1_def partial_state.d2_def
partial_state.dims1_def partial_state.dims2_def nths_vars1' nths_vars2'
using assms unfolding d1_def d2_def by auto
definition ptensor_mat :: "'a::comm_ring_1 mat ⇒ 'a mat ⇒ 'a mat" where
"ptensor_mat m1 m2 = partial_state.tensor_mat dims0 vars1' m1 m2"
lemma ptensor_mat_dim_row [simp]:
"dim_row (ptensor_mat m1 m2) = d0"
by (simp add: ptensor_mat_def partial_state.tensor_mat_dim_row d0_def state_sig.d_def)
lemma ptensor_mat_dim_col [simp]:
"dim_col (ptensor_mat m1 m2) = d0"
by (simp add: ptensor_mat_def partial_state.tensor_mat_dim_col d0_def state_sig.d_def)
lemma ptensor_mat_carrier:
"ptensor_mat m1 m2 ∈ carrier_mat d0 d0"
by (simp add: carrier_matI)
lemma ptensor_mat_add:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d1 d1"
and "m3 ∈ carrier_mat d2 d2"
shows "ptensor_mat (m1 + m2) m3 = ptensor_mat m1 m3 + ptensor_mat m2 m3"
unfolding ptensor_mat_def
apply (rule partial_state.tensor_mat_add1)
unfolding partial_state.d1_def partial_state.d2_def
partial_state.dims1_def partial_state.dims2_def nths_vars1'
nths_vars2'
using assms unfolding d1_def d2_def by auto
lemma ptensor_mat_trace:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d2 d2"
shows "trace (ptensor_mat m1 m2) = trace m1 * trace m2"
unfolding ptensor_mat_def
apply (rule partial_state.tensor_mat_trace)
unfolding partial_state.d1_def partial_state.d2_def
partial_state.dims1_def partial_state.dims2_def nths_vars1' nths_vars2'
using assms unfolding d1_def d2_def by auto
lemma ptensor_mat_id:
"ptensor_mat (1⇩m d1) (1⇩m d2) = 1⇩m d0"
unfolding ptensor_mat_def
by (metis d0_def d1_def d2_def nths_vars1' nths_vars2'
partial_state.d1_def partial_state.d2_def partial_state.dims1_def
partial_state.dims2_def partial_state.tensor_mat_id state_sig.d_def)
lemma ptensor_mat_mult:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d1 d1"
and "m3 ∈ carrier_mat d2 d2"
and "m4 ∈ carrier_mat d2 d2"
shows "ptensor_mat (m1 * m2) (m3 * m4) = ptensor_mat m1 m3 * ptensor_mat m2 m4"
proof -
interpret st: partial_state dims0 vars1'.
have "st.d1 = d1" unfolding st.d1_def st.dims1_def d1_def nths_vars1' by auto
moreover have "st.d2 = d2" unfolding st.d2_def st.dims2_def d2_def nths_vars2' by auto
ultimately show ?thesis unfolding ptensor_mat_def
using st.tensor_mat_mult assms by auto
qed
lemma ptensor_mat_mult_vec:
assumes "m1 ∈ carrier_mat d1 d1"
and "v1 ∈ carrier_vec d1"
and "m2 ∈ carrier_mat d2 d2"
and "v2 ∈ carrier_vec d2"
shows "ptensor_vec (m1 *⇩v v1) (m2 *⇩v v2) = ptensor_mat m1 m2 *⇩v ptensor_vec v1 v2"
proof -
interpret st: partial_state dims0 vars1'.
have "st.d1 = d1" unfolding st.d1_def st.dims1_def d1_def nths_vars1' by auto
moreover have "st.d2 = d2" unfolding st.d2_def st.dims2_def d2_def nths_vars2' by auto
ultimately show ?thesis unfolding ptensor_mat_def ptensor_vec_def
using st.tensor_mat_mult_vec assms by auto
qed
subsection ‹Partial extensions›
definition pmat_extension :: "'a::comm_ring_1 mat ⇒ 'a mat" where
"pmat_extension m = ptensor_mat m (1⇩m d2)"
lemma pmat_extension_carrier:
"pmat_extension m ∈ carrier_mat d0 d0"
by (simp add: pmat_extension_def ptensor_mat_carrier)
lemma pmat_extension_add:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d1 d1"
shows "pmat_extension (m1 + m2) = pmat_extension m1 + pmat_extension m2"
using assms by (simp add: pmat_extension_def ptensor_mat_add)
lemma pmat_extension_trace:
assumes "m ∈ carrier_mat d1 d1"
shows "trace (pmat_extension m) = d2 * trace m"
using assms by (simp add: pmat_extension_def ptensor_mat_trace)
lemma pmat_extension_id:
"pmat_extension (1⇩m d1) = 1⇩m d0"
by (simp add: pmat_extension_def ptensor_mat_id)
lemma pmat_extension_mult:
assumes "m1 ∈ carrier_mat d1 d1"
and "m2 ∈ carrier_mat d1 d1"
shows "pmat_extension (m1 * m2) = pmat_extension m1 * pmat_extension m2"
using assms by (simp add: pmat_extension_def ptensor_mat_mult[symmetric])
end
context state_sig
begin
abbreviation "ptensor_vec ≡ partial_state2.ptensor_vec"
abbreviation "ptensor_mat ≡ partial_state2.ptensor_mat"
abbreviation "pmat_extension ≡ partial_state2.pmat_extension"
text ‹Key property: commutativity of tensor product›
lemma ptensor_mat_comm:
fixes m1 m2 :: "complex mat"
assumes "vars1 ∩ vars2 = {}"
shows "ptensor_mat dims vars1 vars2 m1 m2 = ptensor_mat dims vars2 vars1 m2 m1"
proof -
interpret st1: partial_state2 dims vars1 vars2
apply unfold_locales using assms by auto
interpret st2: partial_state2 dims vars2 vars1
apply unfold_locales using assms by auto
have eq1: "partial_state.encode1 st1.dims0 st1.vars1' = partial_state.encode2 st2.dims0 st2.vars1'"
apply (subst st1.ptensor_encode1_encode2)
unfolding st1.dims0_def st1.vars0_def st1.vars2'_def st2.dims0_def st2.vars0_def st2.vars1'_def
by (subgoal_tac "vars1 ∪ vars2 = vars2 ∪ vars1", auto)
have eq2: "partial_state.encode2 st1.dims0 st1.vars1' = partial_state.encode1 st2.dims0 st2.vars1'"
apply (subst st1.ptensor_encode2_encode1[symmetric])
unfolding st1.dims0_def st1.vars0_def st1.vars2'_def st2.dims0_def st2.vars0_def st2.vars1'_def
by (subgoal_tac "vars1 ∪ vars2 = vars2 ∪ vars1", auto)
show ?thesis unfolding st1.ptensor_mat_def st2.ptensor_mat_def partial_state.tensor_mat_def
apply (rule cong_mat, auto)
subgoal unfolding st1.dims0_def st1.vars0_def st2.dims0_def st2.vars0_def by (subgoal_tac "vars1 ∪ vars2 = vars2 ∪ vars1", auto)
subgoal unfolding st1.dims0_def st1.vars0_def st2.dims0_def st2.vars0_def by (subgoal_tac "vars1 ∪ vars2 = vars2 ∪ vars1", auto)
using eq1 eq2 by auto
qed
text ‹Key property: associativity of tensor product›
lemma ind_in_set_mono:
fixes a b :: nat and A :: "nat set"
assumes "a ∈ A" "b ∈ A" "a < b"
shows "ind_in_set A a < ind_in_set A b"
unfolding ind_in_set_def
apply (rule psubset_card_mono)
subgoal by auto
proof -
have "x ∈ {i ∈ A. i < b}" if "x ∈ {i ∈ A. i < a}" for x
using assms that by auto
moreover have "a ∈ {i ∈ A. i < b}" using assms by auto
moreover have "b ∉ {i ∈ A. i < b}" by auto
ultimately show "{i ∈ A. i < a} ⊂ {i ∈ A. i < b}" by blast
qed
lemma ind_in_set_inj:
fixes a b :: nat and A :: "nat set"
assumes "a ∈ A" "b ∈ A" "ind_in_set A a = ind_in_set A b"
shows "a = b"
proof -
have "ind_in_set A a < ind_in_set A b" if "a < b"
by (rule ind_in_set_mono[OF assms(1) assms(2) that])
moreover have "ind_in_set A b < ind_in_set A a" if "b < a"
by (rule ind_in_set_mono[OF assms(2) assms(1) that])
ultimately show ?thesis using assms(3) by arith
qed
lemma ind_in_set_mono2:
fixes a b :: nat and A :: "nat set"
assumes "a ∈ A" "b ∈ A" "ind_in_set A a < ind_in_set A b"
shows "a < b"
using ind_in_set_mono ind_in_set_inj
by (metis assms not_less_iff_gr_or_eq)
lemma ind_in_set_bij_betw:
fixes A B :: "nat set"
assumes "B ⊆ A" "c ∈ B"
shows "bij_betw (ind_in_set A) {i ∈ B. i < c} {i ∈ ind_in_set A ` B. i < ind_in_set A c}"
unfolding bij_betw_def apply auto
proof -
show "inj_on (ind_in_set A) {i ∈ B. i < c}"
unfolding inj_on_def apply auto
using assms(1) ind_in_set_inj by blast
show "ind_in_set A x < ind_in_set A c" if "x ∈ B" "x < c" for x
by (meson assms that ind_in_set_mono subsetCE)
show "ind_in_set A x ∈ ind_in_set A ` {i ∈ B. i < c}" if "ind_in_set A x < ind_in_set A c" "x ∈ B" for x
using that ind_in_set_mono2 assms by blast
qed
lemma ind_in_set_assoc:
fixes A B C :: "nat set"
assumes "C ⊆ B" "B ⊆ A"
shows "ind_in_set (ind_in_set A ` B) ` (ind_in_set A ` C) = ind_in_set B ` C"
proof -
have "x ∈ ind_in_set (ind_in_set A ` B) ` (ind_in_set A ` C)" if x: "x ∈ ind_in_set B ` C" for x
proof -
obtain c where c: "c ∈ C" and x_eq: "x = card {i ∈ B. i < c}"
using x by (auto simp add: ind_in_set_def)
have "card {i ∈ B. i < c} = card {i ∈ ind_in_set A ` B. i < ind_in_set A c}"
apply (rule bij_betw_same_card)
using c assms by (auto intro: ind_in_set_bij_betw)
then have "ind_in_set (ind_in_set A ` B) (ind_in_set A c) = x"
apply (subst ind_in_set_def) using x_eq by auto
then show ?thesis
using ‹c ∈ C› by blast
qed
moreover have "x ∈ ind_in_set B ` C" if x: "x ∈ ind_in_set (ind_in_set A ` B) ` (ind_in_set A ` C)" for x
proof -
obtain c where c: "c ∈ C" and x_eq: "x = card {i ∈ ind_in_set A ` B. i < ind_in_set A c}"
using x by (auto simp add: ind_in_set_def)
have "card {i ∈ B. i < c} = card {i ∈ ind_in_set A ` B. i < ind_in_set A c}"
apply (rule bij_betw_same_card)
using c assms by (auto intro: ind_in_set_bij_betw)
then have "ind_in_set B c = x"
apply (subst ind_in_set_def) using x_eq by auto
then show ?thesis
using ‹c ∈ C› by blast
qed
ultimately show ?thesis by auto
qed
lemma nths_reencode_eq3:
fixes A B C :: "nat set"
assumes "C ⊆ B" "B ⊆ A"
shows "nths (nths xs (ind_in_set A ` B)) (ind_in_set B ` C) = nths xs (ind_in_set A ` C)"
apply (subst ind_in_set_assoc[OF assms, symmetric])
apply (rule nths_reencode_eq)
using assms by blast
lemma nths_assoc_three_A:
fixes A B C :: "nat set"
assumes "A ∩ B = {}"
and "(A ∪ B) ∩ C = {}"
shows "nths (nths xs (ind_in_set (A ∪ B ∪ C) ` (A ∪ B))) (ind_in_set (A ∪ B) ` A)
= nths xs (ind_in_set (A ∪ B ∪ C) ` A)"
apply (rule nths_reencode_eq3) by auto
lemma nths_assoc_three_B:
fixes A B C :: "nat set"
assumes "A ∩ B = {}"
and "(A ∪ B) ∩ C = {}"
shows "nths (nths xs (ind_in_set (A ∪ B ∪ C) ` (A ∪ B))) (ind_in_set (A ∪ B) ` B)
= nths (nths xs (ind_in_set (A ∪ B ∪ C) ` (B ∪ C))) (ind_in_set (B ∪ C) ` B)"
proof -
have "nths (nths xs (ind_in_set (A ∪ B ∪ C) ` (A ∪ B))) (ind_in_set (A ∪ B) ` B) = nths xs (ind_in_set (A ∪ B ∪ C) ` B)"
using nths_assoc_three_A[of B A C xs] assms by (simp add: inf_commute sup_commute)
moreover have "nths (nths xs (ind_in_set (A ∪ B ∪ C) ` (B ∪ C))) (ind_in_set (B ∪ C) ` B) = nths xs (ind_in_set (A ∪ B ∪ C) ` B)"
using nths_assoc_three_A[of B C A xs] assms by (smt Un_empty inf_commute inf_sup_distrib2 sup_assoc sup_commute)
ultimately show ?thesis by auto
qed
lemma nths_assoc_three_C:
fixes A B C :: "nat set"
assumes "A ∩ B = {}"
and "(A ∪ B) ∩ C = {}"
shows "nths (nths xs (ind_in_set (A ∪ B ∪ C) ` (B ∪ C))) (ind_in_set (B ∪ C) ` C)
= nths xs (ind_in_set (A ∪ B ∪ C) ` C) "
using nths_assoc_three_A[of C B A xs] assms
by (smt Un_empty inf_commute inf_sup_distrib2 sup_assoc sup_commute)
lemma valid_index_ind_in_set:
assumes "is ⊲ nths dims A" "B ⊆ A"
shows "nths is (ind_in_set A ` B) ⊲ nths dims B"
apply (subst nths_reencode_eq[OF assms(2), symmetric])
apply (rule valid_index_nths)
by (rule assms(1))
lemma ind_in_set_id:
fixes A :: "nat set"
assumes "finite A"
shows "ind_in_set A ` A = {0..< card A}"
unfolding ind_in_set_def apply auto
subgoal using assms lt_set_card_lt by auto
proof -
fix x assume x: "x < card A"
have *: "card {i ∈ A. i < pick A x} = x"
apply (rule card_pick_le) by (rule x)
show "x ∈ (λx. card {i ∈ A. i < x}) ` A"
apply (subst *[symmetric])
apply (rule imageI)
apply (rule pick_in_set_le) by (rule x)
qed
lemma nths_complement_ind_in_set:
fixes A B :: "nat set"
assumes "A ∩ B = {}"
"card (A ∪ B) = length xs"
shows "nths xs (- ind_in_set (A ∪ B) ` A) = nths xs (ind_in_set (A ∪ B) ` B)"
apply (rule nths_split_complement_eq[symmetric])
subgoal apply auto using assms(1) ind_in_set_inj
by (metis disjoint_iff_not_equal subsetCE sup_ge1 sup_ge2)
proof -
have *: "ind_in_set (A ∪ B) ` B ∪ ind_in_set (A ∪ B) ` A = ind_in_set (A ∪ B) ` (A ∪ B)"
by auto
show "{0..<length xs} ⊆ ind_in_set (A ∪ B) ` B ∪ ind_in_set (A ∪ B) ` A"
apply (auto simp add: * assms(2))
using ind_in_set_id
by (metis assms(2) atLeastLessThan_iff card.infinite not_le_imp_less not_less_zero)
qed
lemma ind_in_set_inj':
fixes A B :: "nat set"
assumes "B ⊆ A"
shows "inj_on (ind_in_set A) B"
proof (rule inj_onI)
fix x y assume x: "x ∈ B" and y: "y ∈ B" and eq: "ind_in_set A x = ind_in_set A y"
have x': "x ∈ A" using x assms by auto
have y': "y ∈ A" using y assms by auto
show "x = y" by (rule ind_in_set_inj[OF x' y' eq])
qed
lemma ind_in_set_less:
fixes x :: nat and A :: "nat set"
assumes "finite A" "x ∈ A"
shows "ind_in_set A x < card A"
unfolding ind_in_set_def
apply (rule psubset_card_mono) using assms by auto
lemma ptensor_mat_assoc:
assumes "vars1 ∩ vars2 = {}"
and "(vars1 ∪ vars2) ∩ vars3 = {}"
and "vars1 ∪ vars2 ∪ vars3 ⊆ {0..< length dims}"
shows "ptensor_mat dims (vars1 ∪ vars2) vars3 (ptensor_mat dims vars1 vars2 m1 m2) m3 =
ptensor_mat dims vars1 (vars2 ∪ vars3) m1 (ptensor_mat dims vars2 vars3 m2 m3)"
proof -
interpret a: partial_state2 dims vars1 vars2
by (unfold_locales, rule assms(1))
interpret b: partial_state2 dims "vars1 ∪ vars2" vars3
by (unfold_locales, rule assms(2))
interpret c: partial_state2 dims vars2 vars3
apply unfold_locales using assms(2) by auto
interpret d: partial_state2 dims vars1 "vars2 ∪ vars3"
apply unfold_locales using assms by auto
have uassoc: "vars1 ∪ (vars2 ∪ vars3) = vars1 ∪ vars2 ∪ vars3"
by auto
have **: "{i. i < length dims ∧ (i ∈ vars1 ∨ i ∈ vars2 ∨ i ∈ vars3)} = vars1 ∪ vars2 ∪ vars3"
using assms(3) by auto
have finite_union: "finite (vars1 ∪ vars2 ∪ vars3)"
using assms(3)
using subset_eq_atLeast0_lessThan_finite by blast
have m1eq: "digit_encode a.dims0 (digit_decode b.dims1 (nths (digit_encode b.dims0 i) b.vars1'))
= nths (digit_encode b.dims0 i) b.vars1'" if "i < state_sig.d b.dims0" for i
unfolding a.dims0_def a.vars0_def b.dims1_def b.dims0_def b.vars0_def b.vars1'_def
apply (subst digit_encode_decode)
apply (rule valid_index_ind_in_set)
apply (rule digit_encode_valid_index)
using that unfolding state_sig.d_def b.dims0_def b.vars0_def by auto
have m1index: "partial_state.encode1 a.dims0 a.vars1' (partial_state.encode1 b.dims0 b.vars1' i)
= partial_state.encode1 d.dims0 d.vars1' i" if "i < state_sig.d b.dims0" for i
unfolding partial_state.encode1_def partial_state.dims1_def a.nths_vars1' d.nths_vars1' b.nths_vars1'
apply (rule arg_cong[where f="digit_decode d.dims1"])
apply (subst m1eq[OF that])
unfolding a.vars0_def a.vars1'_def b.dims0_def b.vars0_def b.vars1'_def d.dims0_def d.vars0_def d.vars1'_def
using nths_assoc_three_A[OF assms(1-2)] using uassoc by auto
have m2eq1: "digit_encode a.dims0 (digit_decode (nths b.dims0 b.vars1') (nths (digit_encode b.dims0 i) b.vars1'))
= nths (digit_encode b.dims0 i) b.vars1'"
if "i < state_sig.d b.dims0" for i
unfolding a.dims0_def a.vars0_def b.nths_vars1' b.dims1_def
apply (subst digit_encode_decode)
unfolding b.vars1'_def
apply (rule valid_index_ind_in_set)
unfolding b.dims0_def
apply (rule digit_encode_valid_index)
using that unfolding state_sig.d_def b.dims0_def b.vars0_def by auto
have m2eq2: "digit_encode c.dims0 (digit_decode (nths d.dims0 (- d.vars1')) (nths (digit_encode d.dims0 i) (- d.vars1')))
= nths (digit_encode d.dims0 i) (- d.vars1')"
if "i < state_sig.d b.dims0" for i
unfolding c.dims0_def c.vars0_def d.nths_vars2' d.dims2_def
apply (subst digit_encode_decode)
unfolding d.vars1'_def d.vars0_def
apply (subst nths_complement_ind_in_set)
subgoal using assms by auto
subgoal apply (auto simp only: length_digit_encode d.dims0_def d.vars0_def length_nths)
by (auto simp add: ** uassoc)
apply (rule valid_index_ind_in_set)
unfolding d.dims0_def d.vars0_def
apply (rule digit_encode_valid_index)
using that unfolding state_sig.d_def b.dims0_def b.vars0_def using uassoc by auto
have m2index: "partial_state.encode2 a.dims0 a.vars1' (partial_state.encode1 b.dims0 b.vars1' i) =
partial_state.encode1 c.dims0 c.vars1' (partial_state.encode2 d.dims0 d.vars1' i)"
if "i < state_sig.d b.dims0" for i
unfolding partial_state.encode2_def partial_state.encode1_def
partial_state.dims2_def a.nths_vars2' partial_state.dims1_def c.nths_vars1'
a.dims2_def c.dims1_def
apply (rule arg_cong[where f="digit_decode (nths dims vars2)"])
apply (subst m2eq1[OF that])
apply (subst m2eq2[OF that])
unfolding b.dims0_def b.vars0_def b.vars1'_def a.vars1'_def a.vars0_def
d.dims0_def d.vars0_def d.vars1'_def c.vars1'_def c.vars0_def
apply (subst nths_complement_ind_in_set)
subgoal using assms by auto
subgoal apply (auto simp only: length_nths length_digit_encode)
apply (rule bij_betw_same_card[where f="ind_in_set (vars1 ∪ vars2 ∪ vars3)"])
unfolding bij_betw_def apply (rule conjI)
subgoal apply (rule ind_in_set_inj') by auto
apply auto using finite_union by (auto simp add: ** intro: ind_in_set_less)
apply (subst nths_complement_ind_in_set)
subgoal using assms by auto
subgoal apply (auto simp only: length_digit_encode length_nths)
by (auto simp add: ** uassoc)
using nths_assoc_three_B[OF assms(1-2)] uassoc by auto
have m3eq: "digit_encode c.dims0 (digit_decode d.dims2 (nths (digit_encode d.dims0 i) (- d.vars1')))
= nths (digit_encode d.dims0 i) (- d.vars1')" if "i < state_sig.d b.dims0" for i
unfolding c.dims0_def c.vars0_def d.dims2_def d.dims0_def d.vars1'_def d.vars0_def
apply (subst digit_encode_decode)
apply (subst nths_complement_ind_in_set)
subgoal using assms by auto
subgoal apply (auto simp only: length_digit_encode length_nths)
by (auto simp add: ** uassoc)
apply (rule valid_index_ind_in_set)
apply (rule digit_encode_valid_index)
using that unfolding state_sig.d_def b.dims0_def b.vars0_def using uassoc by auto
have m3index: "partial_state.encode2 c.dims0 c.vars1' (partial_state.encode2 d.dims0 d.vars1' i) =
partial_state.encode2 b.dims0 b.vars1' i"
if "i < state_sig.d b.dims0" for i
unfolding partial_state.encode2_def partial_state.dims2_def c.nths_vars2' d.nths_vars2' b.nths_vars2'
apply (rule arg_cong[where f="digit_decode c.dims2"])
apply (subst m3eq[OF that])
unfolding d.dims0_def d.vars0_def d.vars1'_def c.vars1'_def b.dims0_def b.vars1'_def b.vars0_def c.vars0_def
apply (subst nths_complement_ind_in_set)
subgoal using assms by auto
subgoal apply (auto simp only: length_digit_encode length_nths)
by (auto simp add: ** uassoc)
apply (subst nths_complement_ind_in_set)
subgoal using assms by auto
subgoal apply (auto simp only: length_nths length_digit_encode)
apply (rule bij_betw_same_card[where f="ind_in_set (vars1 ∪ vars2 ∪ vars3)"])
unfolding bij_betw_def apply (rule conjI)
subgoal apply (rule ind_in_set_inj') by auto
apply (auto simp add: uassoc) using finite_union
by (auto simp add: ** intro: ind_in_set_less)
apply (subst nths_complement_ind_in_set)
subgoal using assms by auto
subgoal apply (auto simp only: length_nths length_digit_encode)
by (auto simp add: ** uassoc)
using nths_assoc_three_C[OF assms(1-2)] uassoc by auto
show ?thesis
unfolding a.ptensor_mat_def b.ptensor_mat_def c.ptensor_mat_def d.ptensor_mat_def partial_state.tensor_mat_def
apply (rule cong_mat)
subgoal unfolding b.dims0_def d.dims0_def b.vars0_def d.vars0_def
apply (subgoal_tac "vars1 ∪ vars2 ∪ vars3 = vars1 ∪ (vars2 ∪ vars3)") by auto
subgoal unfolding b.dims0_def d.dims0_def b.vars0_def d.vars0_def
apply (subgoal_tac "vars1 ∪ vars2 ∪ vars3 = vars1 ∪ (vars2 ∪ vars3)") by auto
subgoal for i j
proof -
assume lti: "i < state_sig.d b.dims0" and ltj: "j < state_sig.d b.dims0"
have lti': "i < state_sig.d d.dims0" using ‹state_sig.d b.dims0 = state_sig.d d.dims0› lti by auto
have ltj': "j < state_sig.d d.dims0" using ‹state_sig.d b.dims0 = state_sig.d d.dims0› ltj by auto
have eq1: "partial_state.d2 d.dims0 d.vars1' = state_sig.d c.dims0"
unfolding partial_state.d2_def partial_state.dims2_def d.nths_vars2'
d.dims2_def state_sig.d_def c.dims0_def c.vars0_def by auto
have eq2: "partial_state.d1 b.dims0 b.vars1' = state_sig.d a.dims0"
unfolding partial_state.d1_def partial_state.dims1_def b.nths_vars1'
b.dims1_def state_sig.d_def a.dims0_def a.vars0_def by auto
have lt1: "partial_state.encode2 d.dims0 d.vars1' i < state_sig.d c.dims0"
using partial_state.encode2_lt[OF lti', where vars=d.vars1'] eq1 by auto
have lt2: "partial_state.encode2 d.dims0 d.vars1' j < state_sig.d c.dims0"
using partial_state.encode2_lt[OF ltj', where vars=d.vars1'] eq1 by auto
have lt3: "partial_state.encode1 b.dims0 b.vars1' i < state_sig.d a.dims0"
using partial_state.encode1_lt[OF lti, where vars=b.vars1'] eq2 by auto
have lt4: "partial_state.encode1 b.dims0 b.vars1' j < state_sig.d a.dims0"
using partial_state.encode1_lt[OF ltj, where vars=b.vars1'] eq2 by auto
show ?thesis
apply (auto simp add: lt1 lt2 lt3 lt4)
apply (simp only: m1index[OF lti] m1index[OF ltj] m2index[OF lti] m2index[OF ltj] m3index[OF lti] m3index[OF ltj])
by auto
qed
done
qed
text ‹Some simple consequences of associativity›
lemma pmat_extension_assoc:
assumes "vars1 ∩ vars2 = {}"
and "(vars1 ∪ vars2) ∩ vars3 = {}"
and "vars1 ∪ vars2 ∪ vars3 ⊆ {0..< length dims}"
shows "pmat_extension dims vars1 (vars2 ∪ vars3) m =
pmat_extension dims (vars1 ∪ vars2) vars3 (pmat_extension dims vars1 vars2 m)"
proof -
interpret a: partial_state2 dims vars1 vars2
by (unfold_locales, rule assms(1))
interpret b: partial_state2 dims "vars1 ∪ vars2" vars3
by (unfold_locales, rule assms(2))
interpret c: partial_state2 dims vars2 vars3
apply unfold_locales using assms(2) by auto
interpret d: partial_state2 dims vars1 "vars2 ∪ vars3"
apply unfold_locales using assms by auto
have "a.d2 = c.d1"
by (simp add: c.d1_def a.d2_def c.dims1_def a.dims2_def)
have "c.d0 = d.d2"
by (simp add: c.d0_def d.d2_def c.dims0_def d.dims2_def c.vars0_def)
show ?thesis
unfolding a.pmat_extension_def b.pmat_extension_def d.pmat_extension_def
apply (simp add: ptensor_mat_assoc[OF assms])
apply (simp add: ‹a.d2 = c.d1› c.ptensor_mat_id)
by (simp add: ‹c.d0 = d.d2›)
qed
end
subsection ‹Commands on subset of variables›
context state_sig
begin
definition Utrans_P :: "nat set ⇒ complex mat ⇒ com" where
"Utrans_P vars U = Utrans (mat_extension dims vars U)"
lemma well_com_Utrans_P:
assumes "U ∈ carrier_mat (prod_list (nths dims vars)) (prod_list (nths dims vars))"
and "unitary U"
shows "well_com (Utrans_P vars U)"
proof -
have 1: "mat_extension dims vars U ∈ carrier_mat d d"
by (rule partial_state.mat_extension_carrier)
have 2: "unitary (mat_extension dims vars U)"
apply (rule partial_state.mat_extension_unitary)
unfolding partial_state.d1_def partial_state.dims1_def using assms by auto
show "well_com (Utrans_P vars U)"
using 1 2 Utrans_P_def by auto
qed
definition Measure_P :: "nat set ⇒ nat ⇒ (nat ⇒ complex mat) ⇒ com list ⇒ com" where
"Measure_P vars n Ps Cs = Measure n (λn. mat_extension dims vars (Ps n)) Cs"
definition While_P :: "nat set ⇒ complex mat ⇒ complex mat ⇒ com ⇒ com" where
"While_P vars M0 M1 C = While (λn.
if n = 0 then mat_extension dims vars M0
else if n = 1 then mat_extension dims vars M1
else undefined) C"
end
end
Theory Gates
section ‹Standard gates›
theory Gates
imports Complex_Matrix
begin
text ‹Pauli matrices›
definition sigma_x :: "complex mat" where
"sigma_x = mat_of_rows_list 2 [[0, 1], [1, 0]]"
definition sigma_y :: "complex mat" where
"sigma_y = mat_of_rows_list 2 [[0, -𝗂], [𝗂, 0]]"
definition sigma_z :: "complex mat" where
"sigma_z = mat_of_rows_list 2 [[1, 0], [0, -1]]"
text ‹Hadamard matrices›
definition hadamard :: "complex mat" where
"hadamard = mat 2 2 (λ(i, j). if (i = 0 ∨ j = 0) then 1 / csqrt 2 else - 1 / sqrt 2)"
lemma hadamard_dim:
"hadamard ∈ carrier_mat 2 2"
unfolding hadamard_def mat_of_rows_list_def by auto
lemma hermitian_hadamard:
"hermitian hadamard"
unfolding hermitian_def hadamard_def
apply (rule eq_matI) by (auto simp add: adjoint_eval adjoint_dim)
lemma csqrt_2_sq:
"complex_of_real (sqrt 2) * complex_of_real (sqrt 2) = 2"
by (smt of_real_add of_real_hom.hom_one of_real_power one_add_one power2_eq_square real_sqrt_pow2)
lemma sum_le_2:
"⋀(f::nat⇒complex). sum f {0..<2} = f 0 + f 1"
by (simp add: numeral_2_eq_2)
lemma unitary_hadamard:
"unitary hadamard"
unfolding unitary_def apply (rule)
subgoal using carrier_matD[OF hadamard_dim] hadamard_def by auto
apply (subst hermitian_hadamard[unfolded hermitian_def])
unfolding inverts_mat_def
apply (rule eq_matI) unfolding hadamard_def
apply (auto simp add: carrier_matD[OF hadamard_dim] scalar_prod_def)
by (auto simp add: sum_le_2 csqrt_2_sq)
text ‹The matrix
[0 0 .. 0 1
1 0 .. 0 0
0 1 .. 0 0
. . .. . .
0 0 .. 1 0]
implements i := i + 1 in the last variable.
›
definition mat_incr :: "nat ⇒ complex mat" where
"mat_incr n = mat n n (λ(i,j). if i = 0 then (if j = n - 1 then 1 else 0) else (if i = j + 1 then 1 else 0))"
lemma mat_incr_dim:
"mat_incr n ∈ carrier_mat n n"
unfolding mat_incr_def by auto
lemma adjoint_mat_incr:
"adjoint (mat_incr n) = mat n n (λ(i,j). if j = 0 then (if i = n - 1 then 1 else 0) else (if j = i + 1 then 1 else 0))"
apply (rule eq_matI) unfolding mat_incr_def
by (auto simp add: adjoint_eval)
lemma mat_incr_mult_adjoint_mat_incr:
shows "mat_incr n * (adjoint (mat_incr n)) = 1⇩m n"
apply (rule eq_matI, simp)
apply (auto simp add: carrier_matD[OF mat_incr_dim] scalar_prod_def)
unfolding adjoint_mat_incr unfolding mat_incr_def
apply (simp_all)
apply (case_tac "j = 0")
subgoal for j by (simp add: sum_only_one_neq_0[of _ "n - Suc 0"])
subgoal for j by (simp add: sum_only_one_neq_0[of _ "j - 1"])
done
lemma unitary_mat_incr:
"unitary (mat_incr n)"
unfolding unitary_def inverts_mat_def
using carrier_matD[OF mat_incr_dim] mat_incr_mult_adjoint_mat_incr by auto
end
Theory Quantum_Hoare
section ‹Partial and total correctness›
theory Quantum_Hoare
imports Quantum_Program
begin
context state_sig
begin
definition density_states :: "state set" where
"density_states = {ρ ∈ carrier_mat d d. partial_density_operator ρ}"
lemma denote_density_states:
"ρ ∈ density_states ⟹ well_com S ⟹ denote S ρ ∈ density_states"
by (simp add: denote_dim_pdo density_states_def)
definition is_quantum_predicate :: "complex mat ⇒ bool" where
"is_quantum_predicate P ⟷ P ∈ carrier_mat d d ∧ positive P ∧ P ≤⇩L 1⇩m d"
lemma trace_measurement2:
assumes m: "measurement n 2 M" and dA: "A ∈ carrier_mat n n"
shows "trace ((M 0) * A * adjoint (M 0)) + trace ((M 1) * A * adjoint (M 1)) = trace A"
proof -
from m have dM0: "M 0 ∈ carrier_mat n n" and dM1: "M 1 ∈ carrier_mat n n" and id: "adjoint (M 0) * (M 0) + adjoint (M 1) * (M 1) = 1⇩m n"
using measurement_def measurement_id2 by auto
have "trace (M 1 * A * adjoint (M 1)) + trace (M 0 * A * adjoint (M 0))
= trace ((adjoint (M 0) * M 0 + adjoint (M 1) * M 1) * A)"
using dM0 dM1 dA by (mat_assoc n)
also have "… = trace (1⇩m n * A)" using id by auto
also have "… = trace A" using dA by auto
finally show ?thesis
using dA dM0 dM1 local.id state_sig.trace_measure2_id by blast
qed
lemma qp_close_under_unitary_operator:
fixes U P :: "complex mat"
assumes dU: "U ∈ carrier_mat d d"
and u: "unitary U"
and qp: "is_quantum_predicate P"
shows "is_quantum_predicate (adjoint U * P * U)"
unfolding is_quantum_predicate_def
proof (auto)
have dP: "P ∈ carrier_mat d d" using qp is_quantum_predicate_def by auto
show "adjoint U * P * U ∈ carrier_mat d d" using dU dP by fastforce
have "positive P" using qp is_quantum_predicate_def by auto
then show "positive (adjoint U * P * U)"
using positive_close_under_left_right_mult_adjoint[OF adjoint_dim[OF dU] dP, simplified adjoint_adjoint] by fastforce
have "adjoint U * U = 1⇩m d" apply (subgoal_tac "inverts_mat (adjoint U) U")
subgoal unfolding inverts_mat_def using dU by auto
using u unfolding unitary_def using inverts_mat_symm[OF dU adjoint_dim[OF dU]] by auto
then have u': "adjoint U * 1⇩m d * U = 1⇩m d" using dU by auto
have le: "P ≤⇩L 1⇩m d" using qp is_quantum_predicate_def by auto
show "adjoint U * P * U ≤⇩L 1⇩m d"
using lowner_le_keep_under_measurement[OF dU dP one_carrier_mat le] u' by auto
qed
lemma qps_after_measure_is_qp:
assumes m: "measurement d n M " and qpk: "⋀k. k < n ⟹ is_quantum_predicate (P k)"
shows "is_quantum_predicate (matrix_sum d (λk. adjoint (M k) * P k * M k) n)"
unfolding is_quantum_predicate_def
proof (auto)
have dMk: "k < n ⟹ M k ∈ carrier_mat d d" for k using m measurement_def by auto
moreover have dPk: "k < n ⟹ P k ∈ carrier_mat d d" for k using qpk is_quantum_predicate_def by auto
ultimately have dk: "k < n ⟹ adjoint (M k) * P k * M k ∈ carrier_mat d d" for k by fastforce
then show d: "matrix_sum d (λk. adjoint (M k) * P k * M k) n ∈ carrier_mat d d"
using matrix_sum_dim[of n "λk. adjoint (M k) * P k * M k"] by auto
have "k < n ⟹ positive (P k)" for k using qpk is_quantum_predicate_def by auto
then have "k < n ⟹ positive (adjoint (M k) * P k * M k)" for k
using positive_close_under_left_right_mult_adjoint[OF adjoint_dim[OF dMk] dPk, simplified adjoint_adjoint] by fastforce
then show "positive (matrix_sum d (λk. adjoint (M k) * P k * M k) n)" using matrix_sum_positive dk by auto
have "k < n ⟹ P k ≤⇩L 1⇩m d" for k using qpk is_quantum_predicate_def by auto
then have "k < n ⟹ positive (1⇩m d - P k)" for k using lowner_le_def by auto
then have p: "k < n ⟹ positive (adjoint (M k) * (1⇩m d - P k) * M k)" for k
using positive_close_under_left_right_mult_adjoint[OF adjoint_dim[OF dMk], simplified adjoint_adjoint, of _ "1⇩m d - P k"] dPk by fastforce
{
fix k assume k: "k < n"
have "adjoint (M k) * (1⇩m d - P k) * M k = adjoint (M k) * M k - adjoint (M k) * P k * M k"
apply (mat_assoc d) using dMk dPk k by auto
}
note split = this
have dk': "k < n ⟹ adjoint (M k) * M k - adjoint (M k) * P k * M k ∈ carrier_mat d d" for k using dMk dPk by fastforce
have "k < n ⟹ positive (adjoint (M k) * M k - adjoint (M k) * P k * M k)" for k using p split by auto
then have p': "positive (matrix_sum d (λk. adjoint (M k) * M k - adjoint (M k) * P k * M k) n)"
using matrix_sum_positive[OF dk', of n id, simplified] by auto
have daMMk: "k < n ⟹ adjoint (M k) * M k ∈ carrier_mat d d" for k using dMk by fastforce
have daMPMk: "k < n ⟹ adjoint (M k) * P k * M k ∈ carrier_mat d d" for k using dMk dPk by fastforce
have "matrix_sum d (λk. adjoint (M k) * M k - adjoint (M k) * P k * M k) n
= matrix_sum d (λk. adjoint (M k) * M k) n - matrix_sum d (λk. adjoint (M k) * P k * M k) n"
using matrix_sum_minus_distrib[OF daMMk daMPMk] by auto
also have "… = 1⇩m d - matrix_sum d (λk. adjoint (M k) * P k * M k) n" using m measurement_def by auto
finally have "positive (1⇩m d - matrix_sum d (λk. adjoint (M k) * P k * M k) n)" using p' by auto
then show "matrix_sum d (λk. adjoint (M k) * P k * M k) n ≤⇩L 1⇩m d" using lowner_le_def d by auto
qed
definition hoare_total_correct :: "complex mat ⇒ com ⇒ complex mat ⇒ bool" ("⊨⇩t {(1_)}/ (_)/ {(1_)}" 50) where
"⊨⇩t {P} S {Q} ⟷ (∀ρ∈density_states. trace (P * ρ) ≤ trace (Q * denote S ρ))"
definition hoare_partial_correct :: "complex mat ⇒ com ⇒ complex mat ⇒ bool" ("⊨⇩p {(1_)}/ (_)/ {(1_)}" 50) where
"⊨⇩p {P} S {Q} ⟷ (∀ρ∈density_states. trace (P * ρ) ≤ trace (Q * denote S ρ) + (trace ρ - trace (denote S ρ)))"
lemma total_implies_partial:
assumes S: "well_com S"
and total: "⊨⇩t {P} S {Q}"
shows "⊨⇩p {P} S {Q}"
proof -
have "trace (P * ρ) ≤ trace (Q * denote S ρ) + (trace ρ - trace (denote S ρ))" if ρ: "ρ ∈ density_states" for ρ
proof -
have "trace (P * ρ) ≤ trace (Q * denote S ρ)"
using total hoare_total_correct_def ρ by auto
moreover have "trace (denote S ρ) ≤ trace ρ"
using denote_trace[OF S] ρ density_states_def by auto
ultimately show ?thesis by auto
qed
then show ?thesis
using hoare_partial_correct_def by auto
qed
lemma predicate_prob_positive:
assumes "0⇩m d d ≤⇩L P"
and "ρ ∈ density_states"
shows "0 ≤ trace (P * ρ)"
proof -
have "trace (0⇩m d d * ρ) ≤ trace (P * ρ)"
apply (rule lowner_le_traceD)
using assms unfolding lowner_le_def density_states_def by auto
then show ?thesis
using assms(2) density_states_def by auto
qed
lemma total_pre_zero:
assumes S: "well_com S"
and Q: "is_quantum_predicate Q"
shows "⊨⇩t {0⇩m d d} S {Q}"
proof -
have "trace (0⇩m d d * ρ) ≤ trace (Q * denote S ρ)" if ρ: "ρ ∈ density_states" for ρ
proof -
have 1: "trace (0⇩m d d * ρ) = 0"
using ρ unfolding density_states_def by auto
show ?thesis
apply (subst 1)
apply (rule predicate_prob_positive)
subgoal apply (simp add: lowner_le_def, subgoal_tac "Q - 0⇩m d d = Q") using Q is_quantum_predicate_def[of Q] by auto
subgoal using denote_density_states ρ S by auto
done
qed
then show ?thesis
using hoare_total_correct_def by auto
qed
lemma partial_post_identity:
assumes S: "well_com S"
and P: "is_quantum_predicate P"
shows "⊨⇩p {P} S {1⇩m d}"
proof -
have "trace (P * ρ) ≤ trace (1⇩m d * denote S ρ) + (trace ρ - trace (denote S ρ))" if ρ: "ρ ∈ density_states" for ρ
proof -
have "denote S ρ ∈ carrier_mat d d"
using S denote_dim ρ density_states_def by auto
then have "trace (1⇩m d * denote S ρ) = trace (denote S ρ)"
by auto
moreover have "trace (P * ρ) ≤ trace (1⇩m d * ρ)"
apply (rule lowner_le_traceD)
using ρ unfolding density_states_def apply auto
using P is_quantum_predicate_def by auto
ultimately show ?thesis
using density_states_def that by auto
qed
then show ?thesis
using hoare_partial_correct_def by auto
qed
subsection ‹Weakest liberal preconditions›
definition is_weakest_liberal_precondition :: "complex mat ⇒ com ⇒ complex mat ⇒ bool" where
"is_weakest_liberal_precondition W S P ⟷
is_quantum_predicate W ∧ ⊨⇩p {W} S {P} ∧ (∀Q. is_quantum_predicate Q ⟶ ⊨⇩p {Q} S {P} ⟶ Q ≤⇩L W)"
definition wlp_measure :: "nat ⇒ (nat ⇒ complex mat) ⇒ ((complex mat ⇒ complex mat) list) ⇒ complex mat ⇒ complex mat" where
"wlp_measure n M WS P = matrix_sum d (λk. adjoint (M k) * ((WS!k) P) * (M k)) n"
fun wlp_while_n :: "complex mat ⇒ complex mat ⇒ (complex mat ⇒ complex mat) ⇒ nat ⇒ complex mat ⇒ complex mat" where
"wlp_while_n M0 M1 WS 0 P = 1⇩m d"
| "wlp_while_n M0 M1 WS (Suc n) P = adjoint M0 * P * M0 + adjoint M1 * (WS (wlp_while_n M0 M1 WS n P)) * M1"
lemma measurement2_leq_one_mat:
assumes dP: "P ∈ carrier_mat d d" and dQ: "Q ∈ carrier_mat d d"
and leP: "P ≤⇩L 1⇩m d" and leQ: "Q ≤⇩L 1⇩m d" and m: "measurement d 2 M"
shows "(adjoint (M 0) * P * (M 0) + adjoint (M 1) * Q * (M 1)) ≤⇩L 1⇩m d"
proof -
define M0 where "M0 = M 0"
define M1 where "M1 = M 1"
have dM0: "M0 ∈ carrier_mat d d" and dM1: "M1 ∈ carrier_mat d d" using m M0_def M1_def measurement_def by auto
have "adjoint M1 * Q * M1 ≤⇩L adjoint M1 * 1⇩m d * M1"
using lowner_le_keep_under_measurement[OF dM1 dQ _ leQ] by auto
then have le1: "adjoint M1 * Q * M1 ≤⇩L adjoint M1 * M1" using dM1 dQ by fastforce
have "adjoint M0 * P * M0 ≤⇩L adjoint M0 * 1⇩m d * M0"
using lowner_le_keep_under_measurement[OF dM0 dP _ leP] by auto
then have le0: "adjoint M0 * P * M0 ≤⇩L adjoint M0 * M0"
using dM0 dP by fastforce
have "adjoint M0 * P * M0 + adjoint M1 * Q * M1 ≤⇩L adjoint M0 * M0 + adjoint M1 * M1"
apply (rule lowner_le_add[of "adjoint M0 * P * M0" d "adjoint M0 * M0" "adjoint M1 * Q * M1" "adjoint M1 * M1"])
using dM0 dP dM1 dQ le0 le1 by auto
also have "… = 1⇩m d" using m M0_def M1_def measurement_id2 by auto
finally show "adjoint M0 * P * M0 + adjoint M1 * Q * M1 ≤⇩L 1⇩m d".
qed
lemma wlp_while_n_close:
assumes close: "⋀P. is_quantum_predicate P ⟹ is_quantum_predicate (WS P)"
and m: "measurement d 2 M" and qpP: "is_quantum_predicate P"
shows "is_quantum_predicate (wlp_while_n (M 0) (M 1) WS k P)"
proof (induct k)
case 0
then show ?case
unfolding wlp_while_n.simps is_quantum_predicate_def using positive_one[of d] lowner_le_refl[of "1⇩m d"] by fastforce
next
case (Suc k)
define M0 where "M0 = M 0"
define M1 where "M1 = M 1"
define W where "W k = wlp_while_n M0 M1 WS k P" for k
show ?case unfolding wlp_while_n.simps is_quantum_predicate_def
proof (fold M0_def M1_def, fold W_def, auto)
have dM0: "M0 ∈ carrier_mat d d" and dM1: "M1 ∈ carrier_mat d d" using m M0_def M1_def measurement_def by auto
have dP: "P ∈ carrier_mat d d" using qpP is_quantum_predicate_def by auto
have qpWk: "is_quantum_predicate (W k)" using Suc M0_def M1_def W_def by auto
then have qpWWk: "is_quantum_predicate (WS (W k))" using close by auto
from qpWk have dWk: "W k ∈ carrier_mat d d" using is_quantum_predicate_def by auto
from qpWWk have dWWk: "WS (W k) ∈ carrier_mat d d" using is_quantum_predicate_def by auto
show "adjoint M0 * P * M0 + adjoint M1 * WS (W k) * M1 ∈ carrier_mat d d" using dM0 dP dM1 dWWk by auto
have pP: "positive P" using qpP is_quantum_predicate_def by auto
then have pM0P: "positive (adjoint M0 * P * M0)"
using positive_close_under_left_right_mult_adjoint[OF adjoint_dim[OF dM0]] dM0 dP adjoint_adjoint[of M0] by auto
have pWWk: "positive (WS (W k))" using qpWWk is_quantum_predicate_def by auto
then have pM1WWk: "positive (adjoint M1 * WS (W k) * M1)"
using positive_close_under_left_right_mult_adjoint[OF adjoint_dim[OF dM1]] dM1 dWWk adjoint_adjoint[of M1] by auto
then show "positive (adjoint M0 * P * M0 + adjoint M1 * WS (W k) * M1)"
using positive_add[OF pM0P pM1WWk] dM0 dP dM1 dWWk by fastforce
have leWWk: "WS (W k) ≤⇩L 1⇩m d" using qpWWk is_quantum_predicate_def by auto
have leP: "P ≤⇩L 1⇩m d" using qpP is_quantum_predicate_def by auto
show "(adjoint M0 * P * M0 + adjoint M1 * WS (W k) * M1) ≤⇩L 1⇩m d "
using measurement2_leq_one_mat[OF dP dWWk leP leWWk m] M0_def M1_def by auto
qed
qed
lemma wlp_while_n_mono:
assumes "⋀P. is_quantum_predicate P ⟹ is_quantum_predicate (WS P)"
and "⋀P Q. is_quantum_predicate P ⟹ is_quantum_predicate Q ⟹ P ≤⇩L Q ⟹ WS P ≤⇩L WS Q"
and "measurement d 2 M"
and "is_quantum_predicate P"
and "is_quantum_predicate Q"
and "P ≤⇩L Q"
shows "(wlp_while_n (M 0) (M 1) WS k P) ≤⇩L (wlp_while_n (M 0) (M 1) WS k Q)"
proof (induct k)
case 0
then show ?case unfolding wlp_while_n.simps using lowner_le_refl[of "1⇩m d"] by fastforce
next
case (Suc k)
define M0 where "M0 = M 0"
define M1 where "M1 = M 1"
have dM0: "M0 ∈ carrier_mat d d" and dM1: "M1 ∈ carrier_mat d d" using assms M0_def M1_def measurement_def by auto
define W where "W P k = wlp_while_n M0 M1 WS k P" for k P
have dP: "P ∈ carrier_mat d d" and dQ: "Q ∈ carrier_mat d d" using assms is_quantum_predicate_def by auto
have eq1: "W P (Suc k) = adjoint M0 * P * M0 + adjoint M1 * (WS (W P k)) * M1" unfolding W_def wlp_while_n.simps by auto
have eq2: "W Q (Suc k) = adjoint M0 * Q * M0 + adjoint M1 * (WS (W Q k)) * M1" unfolding W_def wlp_while_n.simps by auto
have le1: "adjoint M0 * P * M0 ≤⇩L adjoint M0 * Q * M0" using lowner_le_keep_under_measurement dM0 dP dQ assms by auto
have leWk: "(W P k) ≤⇩L (W Q k)" unfolding W_def M0_def M1_def using Suc by auto
have qpWPk: "is_quantum_predicate (W P k)" unfolding W_def M0_def M1_def using wlp_while_n_close assms by auto
then have "is_quantum_predicate (WS (W P k))" unfolding W_def M0_def M1_def using assms by auto
then have dWWPk: "(WS (W P k)) ∈ carrier_mat d d" using is_quantum_predicate_def by auto
have qpWQk: "is_quantum_predicate (W Q k)" unfolding W_def M0_def M1_def using wlp_while_n_close assms by auto
then have "is_quantum_predicate (WS (W Q k))" unfolding W_def M0_def M1_def using assms by auto
then have dWWQk: "(WS (W Q k)) ∈ carrier_mat d d" using is_quantum_predicate_def by auto
have "(WS (W P k)) ≤⇩L (WS (W Q k))" using qpWPk qpWQk leWk assms by auto
then have le2: "adjoint M1 * (WS (W P k)) * M1 ≤⇩L adjoint M1 * (WS (W Q k)) * M1"
using lowner_le_keep_under_measurement dM1 dWWPk dWWQk by auto
have "(adjoint M0 * P * M0 + adjoint M1 * (WS (W P k)) * M1) ≤⇩L (adjoint M0 * Q * M0 + adjoint M1 * (WS (W Q k)) * M1)"
using lowner_le_add[OF _ _ _ _ le1 le2] dM0 dP dM1 dQ dWWPk dWWQk le1 le2 by fastforce
then have "W P (Suc k) ≤⇩L W Q (Suc k)" using eq1 eq2 by auto
then show ?case unfolding W_def M0_def M1_def by auto
qed
definition wlp_while :: "complex mat ⇒ complex mat ⇒ (complex mat ⇒ complex mat) ⇒ complex mat ⇒ complex mat" where
"wlp_while M0 M1 WS P = (THE Q. limit_mat (λn. wlp_while_n M0 M1 WS n P) Q d)"
lemma wlp_while_exists:
assumes "⋀P. is_quantum_predicate P ⟹ is_quantum_predicate (WS P)"
and "⋀P Q. is_quantum_predicate P ⟹ is_quantum_predicate Q ⟹ P ≤⇩L Q ⟹ WS P ≤⇩L WS Q"
and m: "measurement d 2 M"
and qpP: "is_quantum_predicate P"
shows "is_quantum_predicate (wlp_while (M 0) (M 1) WS P)
∧ (∀n. (wlp_while (M 0) (M 1) WS P) ≤⇩L (wlp_while_n (M 0) (M 1) WS n P))
∧ (∀W'. (∀n. W' ≤⇩L (wlp_while_n (M 0) (M 1) WS n P)) ⟶ W' ≤⇩L (wlp_while (M 0) (M 1) WS P))
∧ limit_mat (λn. wlp_while_n (M 0) (M 1) WS n P) (wlp_while (M 0) (M 1) WS P) d"
proof (auto)
define M0 where "M0 = M 0"
define M1 where "M1 = M 1"
have dM0: "M0 ∈ carrier_mat d d" and dM1: "M1 ∈ carrier_mat d d" using assms M0_def M1_def measurement_def by auto
define W where "W k = wlp_while_n M0 M1 WS k P" for k
have leP: "P ≤⇩L 1⇩m d" and dP: "P ∈ carrier_mat d d" and pP: "positive P" using qpP is_quantum_predicate_def by auto
have pM0P: "positive (adjoint M0 * P * M0)"
using positive_close_under_left_right_mult_adjoint[OF adjoint_dim[OF dM0]] adjoint_adjoint[of "M0"] dP pP by auto
have le_qp: "W (Suc k) ≤⇩L W k ∧ is_quantum_predicate (W k)" for k
proof (induct k)
case 0
have "is_quantum_predicate (1⇩m d)"
unfolding is_quantum_predicate_def using positive_one lowner_le_refl[of "1⇩m d"] by fastforce
then have "is_quantum_predicate (WS (1⇩m d))" using assms by auto
then have "(WS (1⇩m d)) ∈ carrier_mat d d" and "(WS (1⇩m d)) ≤⇩L 1⇩m d" using is_quantum_predicate_def by auto
then have "W 1 ≤⇩L W 0" unfolding W_def wlp_while_n.simps M0_def M1_def
using measurement2_leq_one_mat[OF dP _ leP _ m] by auto
moreover have "is_quantum_predicate (W 0)" unfolding W_def wlp_while_n.simps is_quantum_predicate_def
using positive_one lowner_le_refl[of "1⇩m d"] by fastforce
ultimately show ?case by auto
next
case (Suc k)
then have leWSk: "W (Suc k) ≤⇩L W k" and qpWk: "is_quantum_predicate (W k)" by auto
then have "is_quantum_predicate (WS (W k))" using assms by auto
then have dWWk: "WS (W k) ∈ carrier_mat d d" and leWWk1: "(WS (W k)) ≤⇩L 1⇩m d" and pWWk: "positive (WS (W k))"
using is_quantum_predicate_def by auto
then have leWSk1: "W (Suc k) ≤⇩L 1⇩m d" using measurement2_leq_one_mat[OF dP dWWk leP leWWk1 m]
unfolding W_def wlp_while_n.simps M0_def M1_def by auto
then have dWSk: "W (Suc k) ∈ carrier_mat d d" using lowner_le_def by fastforce
have pM1WWk: "positive (adjoint M1 * (WS (W k)) * M1)"
using positive_close_under_left_right_mult_adjoint[OF adjoint_dim[OF dM1] dWWk pWWk] adjoint_adjoint[of "M1"] by auto
have pWSk: "positive (W (Suc k))" unfolding W_def wlp_while_n.simps apply (fold W_def)
using positive_add[OF pM0P pM1WWk] dM0 dP dM1 by fastforce
have qpWSk:"is_quantum_predicate (W (Suc k))" unfolding is_quantum_predicate_def using dWSk pWSk leWSk1 by auto
then have qpWWSk: "is_quantum_predicate (WS (W (Suc k)))" using assms(1) by auto
then have dWWSk: "(WS (W (Suc k))) ∈ carrier_mat d d" using is_quantum_predicate_def by auto
have "WS (W (Suc k)) ≤⇩L WS (W k)" using assms(2)[OF qpWSk qpWk] leWSk by auto
then have "adjoint M1 * WS (W (Suc k)) * M1 ≤⇩L adjoint M1 * WS (W k) * M1"
using lowner_le_keep_under_measurement[OF dM1 dWWSk dWWk] by auto
then have "(adjoint M0 * P * M0 + adjoint M1 * WS (W (Suc k)) * M1)
≤⇩L (adjoint M0 * P * M0 + adjoint M1 * WS (W k) * M1)"
using lowner_le_add[of _ d _ "adjoint M1 * WS (W (Suc k)) * M1" "adjoint M1 * WS (W k) * M1",
OF _ _ _ _ lowner_le_refl[of "adjoint M0 * P * M0"]] dM0 dM1 dP dWWSk dWWk by fastforce
then have "W (Suc (Suc k)) ≤⇩L W (Suc k)" unfolding W_def wlp_while_n.simps by auto
with qpWSk show ?case by auto
qed
then have dWk: "W k ∈ carrier_mat d d" for k using is_quantum_predicate_def by auto
then have dmWk: "- W k ∈ carrier_mat d d" for k by auto
have incmWk: "- (W k) ≤⇩L - (W (Suc k))" for k using lowner_le_swap[of "W (Suc k)" d "W k"] dWk le_qp by auto
have pWk: "positive (W k)" for k using le_qp is_quantum_predicate_def by auto
have ubmWk: "- W k ≤⇩L 0⇩m d d" for k
proof -
have "0⇩m d d ≤⇩L W k" for k using zero_lowner_le_positiveI dWk pWk by auto
then have "- W k ≤⇩L - 0⇩m d d" for k using lowner_le_swap[of "0⇩m d d" d "W k"] dWk by auto
moreover have "(- 0⇩m d d :: complex mat) = (0⇩m d d)" by auto
ultimately show ?thesis by auto
qed
have "∃B. lowner_is_lub (λk. - W k) B ∧ limit_mat (λk. - W k) B d"
using mat_inc_seq_lub[of "λk. - W k" d "0⇩m d d"] dmWk incmWk ubmWk by auto
then obtain B where lubB: "lowner_is_lub (λk. - W k) B" and limB: "limit_mat (λk. - W k) B d" by auto
then have dB: "B ∈ carrier_mat d d" using limit_mat_def by auto
define A where "A = - B"
then have dA: "A ∈ carrier_mat d d" using dB by auto
have "limit_mat (λk. (-1) ⋅⇩m (- W k)) (-1 ⋅⇩m B) d" using limit_mat_scale[OF limB] by auto
moreover have "W k = -1 ⋅⇩m (- W k)" for k using dWk by auto
moreover have "-1 ⋅⇩m B = - B" by auto
ultimately have limA: "limit_mat W A d" using A_def by auto
moreover have "(limit_mat W A' d ⟹ A' = A)" for A' using limit_mat_unique[of W A d] limA by auto
ultimately have eqA: "(wlp_while (M 0) (M 1) WS P) = A" unfolding wlp_while_def W_def M0_def M1_def
using the_equality[of "λX. limit_mat (λn. wlp_while_n (M 0) (M 1) WS n P) X d" A] by fastforce
show "limit_mat (λn. wlp_while_n (M 0) (M (Suc 0)) WS n P) (wlp_while (M 0) (M (Suc 0)) WS P) d"
using limA eqA unfolding W_def M0_def M1_def by auto
have "- W k ≤⇩L B" for k using lubB lowner_is_lub_def by auto
then have glbA: "A ≤⇩L W k" for k unfolding A_def using lowner_le_swap[of "- W k" d] dB dWk by fastforce
then show "⋀n. wlp_while (M 0) (M (Suc 0)) WS P ≤⇩L wlp_while_n (M 0) (M (Suc 0)) WS n P" using eqA unfolding W_def M0_def M1_def by auto
have "W k ≤⇩L 1⇩m d" for k using le_qp unfolding is_quantum_predicate_def by auto
then have "positive (1⇩m d - W k)" for k using lowner_le_def by auto
moreover have "limit_mat (λk. 1⇩m d - W k) (1⇩m d - A) d" using mat_minus_limit limA by auto
ultimately have "positive (1⇩m d - A)" using pos_mat_lim_is_pos by auto
then have leA1: "A ≤⇩L 1⇩m d" using dA lowner_le_def by auto
have pA: "positive A" using pos_mat_lim_is_pos limA pWk by auto
show "is_quantum_predicate (wlp_while (M 0) (M (Suc 0)) WS P)" unfolding is_quantum_predicate_def using pA dA leA1 eqA by auto
{
fix W' assume asmW': "∀k. W' ≤⇩L W k"
then have dW': "W' ∈ carrier_mat d d" unfolding lowner_le_def using carrier_matD[OF dWk] by auto
then have "- W k ≤⇩L - W'" for k using lowner_le_swap dWk asmW' by auto
then have "B ≤⇩L - W'" using lubB unfolding lowner_is_lub_def by auto
then have "W' ≤⇩L A" unfolding A_def
using lowner_le_swap[of "B" d "- W'"] dB dW' by auto
then have "W' ≤⇩L wlp_while (M 0) (M 1) WS P" using eqA by auto
}
then show "⋀W'. ∀n. W' ≤⇩L wlp_while_n (M 0) (M (Suc 0)) WS n P ⟹ W' ≤⇩L wlp_while (M 0) (M (Suc 0)) WS P"
unfolding W_def M0_def M1_def by auto
qed
lemma wlp_while_mono:
assumes "⋀P. is_quantum_predicate P ⟹ is_quantum_predicate (WS P)"
and "⋀P Q. is_quantum_predicate P ⟹ is_quantum_predicate Q ⟹ P ≤⇩L Q ⟹ WS P ≤⇩L WS Q"
and "measurement d 2 M"
and "is_quantum_predicate P"
and "is_quantum_predicate Q"
and "P ≤⇩L Q"
shows "wlp_while (M 0) (M 1) WS P ≤⇩L wlp_while (M 0) (M 1) WS Q"
proof -
define M0 where "M0 = M 0"
define M1 where "M1 = M 1"
have dM0: "M0 ∈ carrier_mat d d" and dM1: "M1 ∈ carrier_mat d d" using assms M0_def M1_def measurement_def by auto
define Wn where "Wn P k = wlp_while_n M0 M1 WS k P" for P k
define W where "W P = wlp_while M0 M1 WS P" for P
have lePQk: "Wn P k ≤⇩L Wn Q k" for k unfolding Wn_def M0_def M1_def
using wlp_while_n_mono assms by auto
have "is_quantum_predicate (Wn P k)" for k unfolding Wn_def M0_def M1_def using wlp_while_n_close assms by auto
then have dWPk: "Wn P k ∈ carrier_mat d d" for k using is_quantum_predicate_def by auto
have "is_quantum_predicate (Wn Q k)" for k unfolding Wn_def M0_def M1_def using wlp_while_n_close assms by auto
then have dWQk:"Wn Q k ∈ carrier_mat d d" for k using is_quantum_predicate_def by auto
have "is_quantum_predicate (W P)" and lePk: "(W P) ≤⇩L (Wn P k)" and "limit_mat (Wn P) (W P) d" for k
unfolding W_def Wn_def M0_def M1_def using wlp_while_exists assms by auto
then have dWP: "W P ∈ carrier_mat d d" using is_quantum_predicate_def by auto
have "is_quantum_predicate (W Q)" and "(W Q) ≤⇩L (Wn Q k)"
and glb:"(∀k. W' ≤⇩L (Wn Q k)) ⟶ W' ≤⇩L (W Q)" and "limit_mat (Wn Q) (W Q) d" for k W'
unfolding W_def Wn_def M0_def M1_def using wlp_while_exists assms by auto
have "W P ≤⇩L Wn Q k" for k using lowner_le_trans[of "W P" d "Wn P k" "Wn Q k"] lePk lePQk dWPk dWQk dWP by auto
then show "W P ≤⇩L W Q" using glb by auto
qed
fun wlp :: "com ⇒ complex mat ⇒ complex mat" where
"wlp SKIP P = P"
| "wlp (Utrans U) P = adjoint U * P * U"
| "wlp (Seq S1 S2) P = wlp S1 (wlp S2 P)"
| "wlp (Measure n M S) P = wlp_measure n M (map wlp S) P"
| "wlp (While M S) P = wlp_while (M 0) (M 1) (wlp S) P"
lemma wlp_measure_expand_m:
assumes m: "m ≤ n" and wc: "well_com (Measure n M S)"
shows "wlp (Measure m M S) P = matrix_sum d (λk. adjoint (M k) * (wlp (S!k) P) * (M k)) m"
unfolding wlp.simps wlp_measure_def
proof -
have "k < m ⟹ map wlp S ! k = wlp (S!k)" for k using wc m by auto
then have "k < m ⟹ (map wlp S ! k) P = wlp (S!k) P" for k by auto
then show "matrix_sum d (λk. adjoint (M k) * ((map wlp S ! k) P) * (M k)) m
= matrix_sum d (λk. adjoint (M k) * (wlp (S!k) P) * (M k)) m"
using matrix_sum_cong[of m "λk. adjoint (M k) * ((map wlp S ! k) P) * (M k)" "λk. adjoint (M k) * (wlp (S!k) P) * (M k)"] by auto
qed
lemma wlp_measure_expand:
assumes wc: "well_com (Measure n M S)"
shows "wlp (Measure n M S) P = matrix_sum d (λk. adjoint (M k) * (wlp (S!k) P) * (M k)) n"
using wlp_measure_expand_m[OF Nat.le_refl[of n]] wc by auto
lemma wlp_mono_and_close:
shows "well_com S ⟹ is_quantum_predicate P ⟹ is_quantum_predicate Q ⟹ P ≤⇩L Q
⟹ is_quantum_predicate (wlp S P) ∧ wlp S P ≤⇩L wlp S Q"
proof (induct S arbitrary: P Q)
case SKIP
then show ?case by auto
next
case (Utrans U)
then have dU: "U ∈ carrier_mat d d" and u: "unitary U" and qp: "is_quantum_predicate P" and le: "P ≤⇩L Q"
and dP: "P ∈ carrier_mat d d" and dQ: "Q ∈ carrier_mat d d" using is_quantum_predicate_def by auto
then have qp': "is_quantum_predicate (wlp (Utrans U) P)" using qp_close_under_unitary_operator by auto
moreover have "adjoint U * P * U ≤⇩L adjoint U * Q * U" using lowner_le_keep_under_measurement[OF dU dP dQ le] by auto
ultimately show ?case by auto
next
case (Seq S1 S2)
then have qpP: "is_quantum_predicate P" and qpQ: "is_quantum_predicate Q" and wc1: "well_com S1" and wc2: "well_com S2"
and dP: "P ∈ carrier_mat d d" and dQ: "Q ∈ carrier_mat d d" and le: "P ≤⇩L Q"using is_quantum_predicate_def by auto
have qpP2: "is_quantum_predicate (wlp S2 P)" using Seq qpP wc2 by auto
have qpQ2: "is_quantum_predicate (wlp S2 Q)" using Seq(2)[OF wc2 qpQ qpQ] lowner_le_refl dQ by blast
have qpP1: "is_quantum_predicate (wlp S1 (wlp S2 P))"
using Seq(1)[OF wc1 qpP2 qpP2] qpP2 is_quantum_predicate_def[of "wlp S2 P"] lowner_le_refl by auto
have "wlp S2 P ≤⇩L wlp S2 Q" using Seq(2) wc2 qpP qpQ le by auto
then have "wlp S1 (wlp S2 P) ≤⇩L wlp S1 (wlp S2 Q)" using Seq(1) wc1 qpP2 qpQ2 by auto
then show ?case using qpP1 by auto
next
case (Measure n M S)
then have wc: "well_com (Measure n M S)" and wck: "k < n ⟹ well_com (S!k)" and l: "length S = n"
and m: "measurement d n M" and le: "P ≤⇩L Q"
and qpP: "is_quantum_predicate P" and dP: "P ∈ carrier_mat d d"
and qpQ: "is_quantum_predicate Q" and dQ: "Q ∈ carrier_mat d d"
for k using measure_well_com is_quantum_predicate_def by auto
have dMk: "k < n ⟹ M k ∈ carrier_mat d d" for k using m measurement_def by auto
have set: "k < n ⟹ S!k ∈ set S" for k using l by auto
have qpk: "k < n ⟹ is_quantum_predicate (wlp (S!k) P)" for k
using Measure(1)[OF set wck qpP qpP] lowner_le_refl[of P] dP by auto
then have dWkP: "k < n ⟹ wlp (S!k) P ∈ carrier_mat d d" for k using is_quantum_predicate_def by auto
then have dMkP: "k < n ⟹ adjoint (M k) * (wlp (S!k) P) * (M k) ∈ carrier_mat d d" for k using dMk by fastforce
have "k < n ⟹ is_quantum_predicate (wlp (S!k) Q)" for k
using Measure(1)[OF set wck qpQ qpQ] lowner_le_refl[of Q] dQ by auto
then have dWkQ: "k < n ⟹ wlp (S!k) Q ∈ carrier_mat d d" for k using is_quantum_predicate_def by auto
then have dMkQ: "k < n ⟹ adjoint (M k) * (wlp (S!k) Q) * (M k) ∈ carrier_mat d d" for k using dMk by fastforce
have "k < n ⟹ wlp (S!k) P ≤⇩L wlp (S!k) Q" for k
using Measure(1)[OF set wck qpP qpQ le] by auto
then have "k < n ⟹ adjoint (M k) * (wlp (S!k) P) * (M k) ≤⇩L adjoint (M k) * (wlp (S!k) Q) * (M k)" for k
using lowner_le_keep_under_measurement[OF dMk dWkP dWkQ] by auto
then have le': "wlp (Measure n M S) P ≤⇩L wlp (Measure n M S) Q" unfolding wlp_measure_expand[OF wc]
using lowner_le_matrix_sum dMkP dMkQ by auto
have qp': "is_quantum_predicate (wlp (Measure n M S) P)" unfolding wlp_measure_expand[OF wc]
using qps_after_measure_is_qp[OF m] qpk by auto
show ?case using le' qp' by auto
next
case (While M S)
then have m: "measurement d 2 M" and wcs: "well_com S"
and qpP: "is_quantum_predicate P"
by auto
have closeWS: "is_quantum_predicate P ⟹ is_quantum_predicate (wlp S P)" for P
proof -
assume asm: "is_quantum_predicate P"
then have dP: "P ∈ carrier_mat d d" using is_quantum_predicate_def by auto
then show "is_quantum_predicate (wlp S P)" using While(1)[OF wcs asm asm lowner_le_refl] dP by auto
qed
have monoWS: "is_quantum_predicate P ⟹ is_quantum_predicate Q ⟹ P ≤⇩L Q ⟹ wlp S P ≤⇩L wlp S Q" for P Q
using While(1)[OF wcs] by auto
have "is_quantum_predicate (wlp (While M S) P)"
using wlp_while_exists[of "wlp S" M P] closeWS monoWS m qpP by auto
moreover have "wlp (While M S) P ≤⇩L wlp (While M S) Q"
using wlp_while_mono[of "wlp S" M P Q] closeWS monoWS m While by auto
ultimately show ?case by auto
qed
lemma wlp_close:
assumes wc: "well_com S" and qp: "is_quantum_predicate P"
shows "is_quantum_predicate (wlp S P)"
using wlp_mono_and_close[OF wc qp qp] is_quantum_predicate_def[of P] qp lowner_le_refl by auto
lemma wlp_soundness:
"well_com S ⟹
(⋀P. (is_quantum_predicate P ⟹
(∀ρ ∈ density_states. trace (wlp S P * ρ) = trace (P * (denote S ρ)) + trace ρ - trace (denote S ρ))))"
proof (induct S)
case SKIP
then show ?case by auto
next
case (Utrans U)
then have dU: "U ∈ carrier_mat d d" and u: "unitary U" and wc: "well_com (Utrans U)"
and qp: "is_quantum_predicate P" and dP: "P ∈ carrier_mat d d" using is_quantum_predicate_def by auto
have qp': "is_quantum_predicate (wlp (Utrans U) P)" using wlp_close[OF wc qp] by auto
have eq1: "trace (adjoint U * P * U * ρ) = trace (P * (U * ρ * adjoint U))" if dr: "ρ ∈ carrier_mat d d" for ρ
using dr dP apply (mat_assoc d) using wc by auto
have eq2: "trace (U * ρ * adjoint U) = trace ρ" if dr: "ρ ∈ carrier_mat d d" for ρ
using unitary_operator_keep_trace[OF adjoint_dim[OF dU] dr unitary_adjoint[OF dU u]] adjoint_adjoint[of U] by auto
show ?case using qp' eq1 eq2 density_states_def by auto
next
case (Seq S1 S2)
then have qp: "is_quantum_predicate P" and wc1: "well_com S1" and wc2: "well_com S2" by auto
then have qp2: "is_quantum_predicate (wlp S2 P)" using wlp_close by auto
then have qp1: "is_quantum_predicate (wlp S1 (wlp S2 P))" using wlp_close wc1 by auto
have eq1: "trace (wlp S2 P * ρ) = trace (P * denote S2 ρ) + trace ρ - trace (denote S2 ρ)"
if ds: "ρ ∈ density_states" for ρ using Seq(2) wc2 qp ds by auto
have eq2: "trace (wlp S1 (wlp S2 P) * ρ) = trace ((wlp S2 P) * denote S1 ρ) + trace ρ - trace (denote S1 ρ)"
if ds: "ρ ∈ density_states" for ρ using Seq(1) wc1 qp2 ds by auto
have eq3: "trace (wlp S1 (wlp S2 P) * ρ) = trace (P * (denote S2 (denote S1 ρ))) + trace ρ - trace (denote S2 (denote S1 ρ))"
if ds: "ρ ∈ density_states" for ρ
proof -
have "denote S1 ρ ∈ density_states"
using ds denote_density_states wc1 by auto
then have "trace ((wlp S2 P) * denote S1 ρ) = trace (P * denote S2 (denote S1 ρ)) + trace (denote S1 ρ) - trace (denote S2 (denote S1 ρ))"
using eq1 by auto
then show "trace (wlp S1 (wlp S2 P) * ρ) = trace (P * (denote S2 (denote S1 ρ))) + trace ρ - trace (denote S2 (denote S1 ρ))"
using eq2 ds by auto
qed
then show ?case using qp1 by auto
next
case (Measure n M S)
then have wc: "well_com (Measure n M S)"
and wck: "k < n ⟹ well_com (S!k)"
and qpP: "is_quantum_predicate P"
and dP: "P ∈ carrier_mat d d"
and qpWk: "k < n ⟹ is_quantum_predicate (wlp (S!k) P)"
and dWk: "k < n ⟹ (wlp (S!k) P) ∈ carrier_mat d d"
and c: "k < n ⟹ ρ ∈ density_states ⟹ trace (wlp (S!k) P * ρ) = trace (P * denote (S!k) ρ) + trace ρ - trace (denote (S!k) ρ)"
and m: "measurement d n M"
and aMMkleq: "k < n ⟹ adjoint (M k) * M k ≤⇩L 1⇩m d"
and dMk: "k < n ⟹ M k ∈ carrier_mat d d"
for k ρ using is_quantum_predicate_def measurement_def measure_well_com measurement_le_one_mat wlp_close by auto
{
fix ρ assume ρ: "ρ ∈ density_states"
then have dr: "ρ ∈ carrier_mat d d" and pdor: "partial_density_operator ρ" using density_states_def by auto
have dsr: "k < n ⟹ (M k) * ρ * adjoint (M k) ∈ density_states" for k unfolding density_states_def
using dMk pdo_close_under_measurement[OF dMk dr pdor aMMkleq] dr by fastforce
then have leqk: "k < n ⟹ trace (wlp (S!k) P * ((M k) * ρ * adjoint (M k))) =
trace (P * (denote (S!k) ((M k) * ρ * adjoint (M k)))) +
(trace ((M k) * ρ * adjoint (M k)) - trace (denote (S ! k) ((M k) * ρ * adjoint (M k))))" for k
using c by auto
have "k < n ⟹ M k * ρ * adjoint (M k) ∈ carrier_mat d d" for k using dMk dr by fastforce
then have dsMrk: "k < n ⟹ matrix_sum d (λk. (M k * ρ * adjoint (M k))) k ∈ carrier_mat d d" for k
using matrix_sum_dim[of k "λk. (M k * ρ * adjoint (M k))" d] by fastforce
have "k < n ⟹ adjoint (M k) * (wlp (S!k) P) * M k ∈ carrier_mat d d" for k using dMk by fastforce
then have dsMW: "k < n ⟹ matrix_sum d (λk. adjoint (M k) * (wlp (S!k) P) * M k) k ∈ carrier_mat d d" for k
using matrix_sum_dim[of k "λk. adjoint (M k) * (wlp (S!k) P) * M k" d] by fastforce
have dSMrk: "k < n ⟹ denote (S ! k) (M k * ρ * adjoint (M k)) ∈ carrier_mat d d" for k
using denote_dim[OF wck, of k "M k * ρ * adjoint (M k)"] dsr density_states_def by fastforce
have dsSMrk: "k < n ⟹ matrix_sum d (λk. denote (S!k) (M k * ρ * adjoint (M k))) k ∈ carrier_mat d d" for k
using matrix_sum_dim[of k "λk. denote (S ! k) (M k * ρ * adjoint (M k))" d, OF dSMrk] by fastforce
have "k ≤ n ⟹
trace (matrix_sum d (λk. adjoint (M k) * (wlp (S!k) P) * M k) k * ρ)
= trace (P * (denote (Measure k M S) ρ)) + (trace (matrix_sum d (λk. (M k) * ρ * adjoint (M k)) k) - trace (denote (Measure k M S) ρ))" for k
unfolding denote_measure_expand[OF _ wc]
proof (induct k)
case 0
then show ?case unfolding matrix_sum.simps using dP dr by auto
next
case (Suc k)
then have k: "k < n" by auto
have eq1: "trace (matrix_sum d (λk. adjoint (M k) * (wlp (S!k) P) * M k) (Suc k) * ρ)
= trace (adjoint (M k) * (wlp (S!k) P) * M k * ρ) + trace (matrix_sum d (λk. adjoint (M k) * (wlp (S!k) P) * M k) k * ρ)"
unfolding matrix_sum.simps
using dMk[OF k] dWk[OF k] dr dsMW[OF k] by (mat_assoc d)
have "trace (adjoint (M k) * (wlp (S!k) P) * M k * ρ) = trace ((wlp (S!k) P) * (M k * ρ * adjoint (M k)))"
using dMk[OF k] dWk[OF k] dr by (mat_assoc d)
also have "… = trace (P * (denote (S!k) ((M k) * ρ * adjoint (M k)))) +
(trace ((M k) * ρ * adjoint (M k)) - trace (denote (S ! k) ((M k) * ρ * adjoint (M k))))" using leqk k by auto
finally have eq2: "trace (adjoint (M k) * (wlp (S!k) P) * M k * ρ) = trace (P * (denote (S!k) ((M k) * ρ * adjoint (M k)))) +
(trace ((M k) * ρ * adjoint (M k)) - trace (denote (S ! k) ((M k) * ρ * adjoint (M k))))" .
have eq3: "trace (P * matrix_sum d (λk. denote (S!k) (M k * ρ * adjoint (M k))) (Suc k))
= trace (P * (denote (S!k) (M k * ρ * adjoint (M k)))) + trace (P * matrix_sum d (λk. denote (S!k) (M k * ρ * adjoint (M k))) k)"
unfolding matrix_sum.simps
using dP dSMrk[OF k] dsSMrk[OF k] by (mat_assoc d)
have eq4: "trace (denote (S ! k) (M k * ρ * adjoint (M k)) + matrix_sum d (λk. denote (S!k) (M k * ρ * adjoint (M k))) k)
= trace (denote (S ! k) (M k * ρ * adjoint (M k))) + trace (matrix_sum d (λk. denote (S!k) (M k * ρ * adjoint (M k))) k)"
using dSMrk[OF k] dsSMrk[OF k] by (mat_assoc d)
show ?case
apply (subst eq1) apply (subst eq3)
apply (simp del: less_eq_complex_def)
apply (subst trace_add_linear[of "M k * ρ * adjoint (M k)" d "matrix_sum d (λk. M k * ρ * adjoint (M k)) k"])
apply (simp add: dMk adjoint_dim[OF dMk] dr mult_carrier_mat[of _ d d _ d] k)
apply (simp add: dsMrk k)
apply (subst eq4)
apply (insert eq2 Suc(1) k, fastforce)
done
qed
then have leq: "trace (matrix_sum d (λk. adjoint (M k) * (wlp (S!k) P) * M k) n * ρ)
= trace (P * denote (Measure n M S) ρ) +
(trace (matrix_sum d (λk. (M k) * ρ * adjoint (M k)) n) - trace (denote (Measure n M S) ρ))"
by auto
have "trace (matrix_sum d (λk. (M k) * ρ * adjoint (M k)) n) = trace ρ" using trace_measurement m dr by auto
with leq have "trace (matrix_sum d (λk. adjoint (M k) * (wlp (S!k) P) * M k) n * ρ)
= trace (P * denote (Measure n M S) ρ) + (trace ρ - trace (denote (Measure n M S) ρ))"
unfolding denote_measure_def by auto
}
then show ?case unfolding wlp_measure_expand[OF wc] by auto
next
case (While M S)
then have qpP: "is_quantum_predicate P" and dP: "P ∈ carrier_mat d d"
and wcS: "well_com S" and m: "measurement d 2 M" and wc: "well_com (While M S)"
using is_quantum_predicate_def by auto
define M0 where "M0 = M 0"
define M1 where "M1 = M 1"
have dM0: "M0 ∈ carrier_mat d d" and dM1: "M1 ∈ carrier_mat d d" using m measurement_def M0_def M1_def by auto
have leM1: "adjoint M1 * M1 ≤⇩L 1⇩m d" using measurement_le_one_mat m M1_def by auto
define W where "W k = wlp_while_n M0 M1 (wlp S) k P" for k
define DS where "DS = denote S"
define D0 where "D0 = denote_while_n M0 M1 DS"
define D1 where "D1 = denote_while_n_comp M0 M1 DS"
define D where "D = denote_while_n_iter M0 M1 DS"
have eqk: "ρ ∈ density_states ⟹ trace ((W k) * ρ) = (∑k=0..<k. trace (P * (D0 k ρ))) + trace ρ - (∑k=0..<k. trace (D0 k ρ))" for k ρ
proof (induct k arbitrary: ρ)
case 0
then have dsr: "ρ ∈ density_states" by auto
show ?case unfolding W_def wlp_while_n.simps using dsr density_states_def by auto
next
case (Suc k)
then have dsr: "ρ ∈ density_states" and dr: "ρ ∈ carrier_mat d d" and pdor: "partial_density_operator ρ" using density_states_def by auto
then have dsM1r: "M1 * ρ * adjoint M1 ∈ density_states" unfolding density_states_def using pdo_close_under_measurement[OF dM1 dr pdor leM1] dr dM1 by auto
then have dsDSM1r: "(DS (M1 * ρ * adjoint M1)) ∈ density_states" unfolding density_states_def DS_def
using denote_dim[OF wcS] denote_partial_density_operator[OF wcS] dsM1r by auto
have qpWk: "is_quantum_predicate (W k)"
using wlp_while_n_close[OF _ m qpP, folded M0_def M1_def, of "wlp S", folded W_def] wlp_close[OF wcS] by auto
then have "is_quantum_predicate (wlp S (W k))" using wlp_close[OF wcS] by auto
then have dWWk: "wlp S (W k) ∈ carrier_mat d d" using is_quantum_predicate_def by auto
have "trace (P * (M0 * ρ * adjoint M0)) + (∑k=0..<k. trace (P * (D0 k (DS (M1 * ρ * adjoint M1)))))
= trace (P * (D0 0 ρ)) + (∑k=0..<k. trace (P * (D0 (Suc k) ρ)))"
unfolding D0_def by auto
also have "… = trace (P * (D0 0 ρ)) + (∑k=1..<(Suc k). trace (P * (D0 k ρ)))"
using sum.shift_bounds_Suc_ivl[symmetric, of "λk. trace (P * (D0 k ρ))"] by auto
also have "… = (∑k=0..<(Suc k). trace (P * (D0 k ρ)))" using sum.atLeast_Suc_lessThan[of 0 "Suc k" "λk. trace (P * (D0 k ρ))"] by auto
finally have eq1: "trace (P * (M0 * ρ * adjoint M0)) + (∑k=0..<k. trace (P * (D0 k (DS (M1 * ρ * adjoint M1)))))
= (∑k=0..<(Suc k). trace (P * (D0 k ρ)))".
have eq2: "trace (M1 * ρ * adjoint M1) = trace ρ - trace (M0 * ρ * adjoint M0)"
unfolding M0_def M1_def using m trace_measurement2[OF m dr] dr by (simp add: algebra_simps)
have "trace (M0 * ρ * adjoint M0) + (∑k=0..<k. trace (D0 k (DS (M1 * ρ * adjoint M1))))
= trace (D0 0 ρ) + (∑k=0..<k. trace (D0 (Suc k) ρ))" unfolding D0_def by auto
also have "… = trace (D0 0 ρ) + (∑k=1..<(Suc k). trace (D0 k ρ))"
using sum.shift_bounds_Suc_ivl[symmetric, of "λk. trace (D0 k ρ)"] by auto
also have "… = (∑k=0..<(Suc k). trace (D0 k ρ))"
using sum.atLeast_Suc_lessThan[of 0 "Suc k" "λk. trace (D0 k ρ)"] by auto
finally have eq3: "trace (M0 * ρ * adjoint M0) + (∑k=0..<k. trace (D0 k (DS (M1 * ρ * adjoint M1)))) = (∑k=0..<(Suc k). trace (D0 k ρ))".
then have "trace (M1 * ρ * adjoint M1) - (∑k=0..<k. trace (D0 k (DS (M1 * ρ * adjoint M1))))
= trace ρ - (trace (M0 * ρ * adjoint M0) + (∑k=0..<k. trace (D0 k (DS (M1 * ρ * adjoint M1)))))"
by (simp add: algebra_simps eq2)
then have eq4: "trace (M1 * ρ * adjoint M1) - (∑k=0..<k. trace (D0 k (DS (M1 * ρ * adjoint M1)))) = trace ρ - (∑k=0..<(Suc k). trace (D0 k ρ))"
by (simp add: eq3)
have "trace ((W (Suc k)) * ρ) = trace (P * (M0 * ρ * adjoint M0)) + trace ((wlp S (W k)) * (M1 * ρ * adjoint M1))"
unfolding W_def wlp_while_n.simps
apply (fold W_def) using dM0 dP dM1 dWWk dr by (mat_assoc d)
also have "… = trace (P * (M0 * ρ * adjoint M0)) + trace ((W k) * (DS (M1 * ρ * adjoint M1))) + trace (M1 * ρ * adjoint M1) - trace (DS (M1 * ρ * adjoint M1))"
using While(1)[OF wcS, of "W k"] qpWk dsM1r DS_def by auto
also have "… = trace (P * (M0 * ρ * adjoint M0))
+ (∑k=0..<k. trace (P * (D0 k (DS (M1 * ρ * adjoint M1))))) + trace (DS (M1 * ρ * adjoint M1)) - (∑k=0..<k. trace (D0 k (DS (M1 * ρ * adjoint M1))))
+ trace (M1 * ρ * adjoint M1) - trace (DS (M1 * ρ * adjoint M1))"
using Suc(1)[OF dsDSM1r] by auto
also have "… = trace (P * (M0 * ρ * adjoint M0)) + (∑k=0..<k. trace (P * (D0 k (DS (M1 * ρ * adjoint M1)))))
+ trace (M1 * ρ * adjoint M1) - (∑k=0..<k. trace (D0 k (DS (M1 * ρ * adjoint M1))))"
by auto
also have "… = (∑k=0..<(Suc k). trace (P * (D0 k ρ))) + trace ρ - (∑k=0..<(Suc k). trace (D0 k ρ))"
by (simp add: eq1 eq4)
finally show ?case.
qed
{
fix ρ assume dsr: "ρ ∈ density_states"
then have dr: "ρ ∈ carrier_mat d d" and pdor: "partial_density_operator ρ" using density_states_def by auto
have limDW: "limit_mat (λn. matrix_sum d (λk. D0 k ρ) (n)) (denote (While M S) ρ) d"
using limit_mat_denote_while_n[OF wc dr pdor] unfolding D0_def M0_def M1_def DS_def by auto
then have "limit_mat (λn. (P * (matrix_sum d (λk. D0 k ρ) (n)))) (P * (denote (While M S) ρ)) d"
using mat_mult_limit[OF dP] unfolding mat_mult_seq_def by auto
then have limtrPm: "(λn. trace (P * (matrix_sum d (λk. D0 k ρ) (n)))) ⇢ trace (P * (denote (While M S) ρ))"
using mat_trace_limit by auto
with limDW have limtrDW:"(λn. trace (matrix_sum d (λk. D0 k ρ) (n))) ⇢ trace (denote (While M S) ρ)"
using mat_trace_limit by auto
have limm: "(λn. trace (matrix_sum d (λk. D0 k ρ) (n))) ⇢ trace (denote (While M S) ρ)"
using mat_trace_limit limDW by auto
have closeWS: "is_quantum_predicate P ⟹ is_quantum_predicate (wlp S P)" for P
proof -
assume asm: "is_quantum_predicate P"
then have dP: "P ∈ carrier_mat d d" using is_quantum_predicate_def by auto
then show "is_quantum_predicate (wlp S P)" using wlp_mono_and_close[OF wcS asm asm] lowner_le_refl by auto
qed
have monoWS: "is_quantum_predicate P ⟹ is_quantum_predicate Q ⟹ P ≤⇩L Q ⟹ wlp S P ≤⇩L wlp S Q" for P Q
using wlp_mono_and_close[OF wcS] by auto
have "is_quantum_predicate (wlp (While M S) P)"
using wlp_while_exists[of "wlp S" M P] closeWS monoWS m qpP by auto
have "limit_mat W (wlp_while M0 M1 (wlp S) P) d" unfolding W_def M0_def M1_def
using wlp_while_exists[of "wlp S" M P] closeWS monoWS m qpP by auto
then have "limit_mat (λk. (W k) * ρ) ((wlp_while M0 M1 (wlp S) P) * ρ) d" using mult_mat_limit dr by auto
then have lim1: "(λk. trace ((W k) * ρ)) ⇢ trace ((wlp_while M0 M1 (wlp S) P) * ρ)"
using mat_trace_limit by auto
have dD0kr: "D0 k ρ ∈ carrier_mat d d" for k unfolding D0_def
using denote_while_n_dim[OF dr dM0 dM1 pdor] denote_positive_trace_dim[OF wcS, folded DS_def] by auto
then have "(P * (matrix_sum d (λk. D0 k ρ) (n))) = matrix_sum d (λk. P * (D0 k ρ)) n" for n
using matrix_sum_distrib_left[OF dP] by auto
moreover have "trace (matrix_sum d (λk. P * (D0 k ρ)) n) = (∑k=0..<n. trace (P * (D0 k ρ)))" for n
using trace_matrix_sum_linear dD0kr dP by auto
ultimately have eqPsD0kr: "trace (P * (matrix_sum d (λk. D0 k ρ) (n))) = (∑k=0..<n. trace (P * (D0 k ρ)))" for n by auto
with limtrPm have lim2: "(λk. (∑k=0..<k. trace (P * (D0 k ρ)))) ⇢ trace (P * (denote (While M S) ρ))" by auto
have "trace (matrix_sum d (λk. D0 k ρ) (n)) = (∑k=0..<n. trace (D0 k ρ))" for n
using trace_matrix_sum_linear dD0kr by auto
with limtrDW have lim3: "(λk. (∑k=0..<k. trace (D0 k ρ))) ⇢ trace (denote (While M S) ρ)" by auto
have "(λk. (∑k=0..<k. trace (P * (D0 k ρ))) + trace ρ) ⇢ trace (P * (denote (While M S) ρ)) + trace ρ"
using tendsto_add[of "λk. (∑k=0..<k. trace (P * (D0 k ρ)))"] lim2 by auto
then have "(λk. (∑k=0..<k. trace (P * (D0 k ρ))) + trace ρ - (∑k=0..<k. trace (D0 k ρ)))
⇢ trace (P * (denote (While M S) ρ)) + trace ρ - trace (denote (While M S) ρ)"
using tendsto_diff[of _ _ _ "λk. (∑k=0..<k. trace (D0 k ρ))"] lim3 by auto
then have lim4: "(λk. trace ((W k) * ρ)) ⇢ trace (P * (denote (While M S) ρ)) + trace ρ - trace (denote (While M S) ρ)"
using eqk[OF dsr] by auto
then have "trace ((wlp_while M0 M1 (wlp S) P) * ρ) = trace (P * (denote (While M S) ρ)) + trace ρ - trace (denote (While M S) ρ)"
using eqk[OF dsr] tendsto_unique[OF _ lim1 lim4] by auto
}
then show ?case unfolding M0_def M1_def DS_def wlp.simps by auto
qed
lemma denote_while_split:
assumes wc: "well_com (While M S)" and dsr: "ρ ∈ density_states"
shows "denote (While M S) ρ = (M 0) * ρ * adjoint (M 0) + denote (While M S) (denote S (M 1 * ρ * adjoint (M 1)))"
proof -
have m: "measurement d 2 M" using wc by auto
have wcs: "well_com S" using wc by auto
define M0 where "M0 = M 0"
define M1 where "M1 = M 1"
have dM0: "M0 ∈ carrier_mat d d" and dM1: "M1 ∈ carrier_mat d d" using m measurement_def M0_def M1_def by auto
have M1leq: "adjoint M1 * M1 ≤⇩L 1⇩m d" using measurement_le_one_mat m M1_def by auto
define DS where "DS = denote S"
define D0 where "D0 = denote_while_n M0 M1 DS"
define D1 where "D1 = denote_while_n_comp M0 M1 DS"
define D where "D = denote_while_n_iter M0 M1 DS"
define DW where "DW ρ = denote (While M S) ρ" for ρ
{
fix ρ assume dsr: "ρ ∈ density_states"
then have dr: "ρ ∈ carrier_mat d d" and pdor: "partial_density_operator ρ" using density_states_def by auto
have pdoDkr: "⋀k. partial_density_operator (D k ρ)" unfolding D_def
using pdo_denote_while_n_iter[OF dr pdor dM1 M1leq]
denote_partial_density_operator[OF wcs] denote_dim[OF wcs, folded DS_def]
apply (fold DS_def) by auto
then have pDkr: "⋀k. positive (D k ρ)" unfolding partial_density_operator_def by auto
have dDkr: "⋀k. D k ρ ∈ carrier_mat d d"
using denote_while_n_iter_dim[OF dr pdor dM1 M1leq denote_dim_pdo[OF wcs, folded DS_def], of id M0, simplified, folded D_def] by auto
then have dD0kr: "⋀k. D0 k ρ ∈ carrier_mat d d" unfolding D0_def denote_while_n.simps apply (fold D_def) using dM0 by auto
}
note dD0k = this
have "matrix_sum d (λk. D0 k ρ) k ∈ carrier_mat d d" if dsr: "ρ ∈ density_states" for ρ k
using matrix_sum_dim[OF dD0k, of _ "λk. ρ" id, OF dsr] dsr by auto
{
fix k
have "matrix_sum d (λk. D0 k ρ) (Suc k) = (D0 0 ρ) + matrix_sum d (λk. D0 (Suc k) ρ) k"
using matrix_sum_shift_Suc[of _ "λk. D0 k ρ"] dD0k[OF dsr] by fastforce
also have "… = M0 * ρ * adjoint M0 + matrix_sum d (λk. D0 k (DS (M1 * ρ * adjoint M1))) k"
unfolding D0_def by auto
finally have "matrix_sum d (λk. D0 k ρ) (Suc k) = M0 * ρ * adjoint M0 + matrix_sum d (λk. D0 k (DS (M1 * ρ * adjoint M1))) k".
}
note eqk = this
have dr: "ρ ∈ carrier_mat d d" and pdor: "partial_density_operator ρ" using density_states_def dsr by auto
then have "M1 * ρ * adjoint M1 ∈ carrier_mat d d" and "partial_density_operator (M1 * ρ * adjoint M1)"
using dM1 dr pdo_close_under_measurement[OF dM1 dr pdor M1leq] by auto
then have dSM1r: "(DS (M1 * ρ * adjoint M1)) ∈ carrier_mat d d" and pdoSM1r: "partial_density_operator (DS (M1 * ρ * adjoint M1))"
unfolding DS_def using denote_dim_pdo[OF wcs] by auto
have "limit_mat (matrix_sum d (λk. D0 k ρ)) (DW ρ) d" unfolding M0_def M1_def D0_def DS_def DW_def
using limit_mat_denote_while_n[OF wc dr pdor] by auto
then have liml: "limit_mat (λk. matrix_sum d (λk. D0 k ρ) (Suc k)) (DW ρ) d"
using limit_mat_ignore_initial_segment[of "matrix_sum d (λk. D0 k ρ)" "DW ρ" d 1] by auto
have dM0r: "M0 * ρ * adjoint M0 ∈ carrier_mat d d" using dM0 dr by fastforce
have "limit_mat (matrix_sum d (λk. D0 k (DS (M1 * ρ * adjoint M1)))) (DW (DS (M1 * ρ * adjoint M1))) d"
using limit_mat_denote_while_n[OF wc dSM1r pdoSM1r] unfolding M0_def M1_def D0_def DS_def DW_def by auto
then have
limr: "limit_mat
(mat_add_seq (M0 * ρ * adjoint M0) (matrix_sum d (λk. D0 k (DS (M1 * ρ * adjoint M1)))))
(M0 * ρ * adjoint M0 + (DW (DS (M1 * ρ * adjoint M1))))
d"
using mat_add_limit[OF dM0r] by auto
moreover have
"(λk. matrix_sum d (λk. D0 k ρ) (Suc k))
= (mat_add_seq (M0 * ρ * adjoint M0) (matrix_sum d (λk. D0 k (DS (M1 * ρ * adjoint M1)))))"
using eqk mat_add_seq_def by auto
ultimately have
"limit_mat
(λk. matrix_sum d (λk. D0 k ρ) (Suc k))
(M0 * ρ * adjoint M0 + (DW (DS (M1 * ρ * adjoint M1))))
d" by auto
with liml limit_mat_unique have
"DW ρ = (M0 * ρ * adjoint M0 + (DW (DS (M1 * ρ * adjoint M1))))" by auto
then show ?thesis unfolding DW_def M0_def M1_def DS_def by auto
qed
lemma wlp_while_split:
assumes wc: "well_com (While M S)" and qpP: "is_quantum_predicate P"
shows "wlp (While M S) P = adjoint (M 0) * P * (M 0) + adjoint (M 1) * (wlp S (wlp (While M S) P)) * (M 1)"
proof -
have m: "measurement d 2 M" using wc by auto
have wcs: "well_com S" using wc by auto
define M0 where "M0 = M 0"
define M1 where "M1 = M 1"
have dM0: "M0 ∈ carrier_mat d d" and dM1: "M1 ∈ carrier_mat d d" using m measurement_def M0_def M1_def by auto
have M1leq: "adjoint M1 * M1 ≤⇩L 1⇩m d" using measurement_le_one_mat m M1_def by auto
define DS where "DS = denote S"
define D0 where "D0 = denote_while_n M0 M1 DS"
define D1 where "D1 = denote_while_n_comp M0 M1 DS"
define D where "D = denote_while_n_iter M0 M1 DS"
define DW where "DW ρ = denote (While M S) ρ" for ρ
have dP: "P ∈ carrier_mat d d" using qpP is_quantum_predicate_def by auto
have qpWP: "is_quantum_predicate (wlp (While M S) P)" using qpP wc wlp_close[OF wc qpP] by auto
then have "is_quantum_predicate (wlp S (wlp (While M S) P))" using wc wlp_close[OF wcs] by auto
then have dWWP: "(wlp S (wlp (While M S) P)) ∈ carrier_mat d d" using is_quantum_predicate_def by auto
have dWP: "(wlp (While M S) P) ∈ carrier_mat d d" using qpWP is_quantum_predicate_def by auto
{
fix ρ assume dsr: "ρ ∈ density_states"
then have dr: "ρ ∈ carrier_mat d d" and pdor: "partial_density_operator ρ" using density_states_def by auto
have dsM1r: "M1 * ρ * adjoint M1 ∈ density_states" unfolding density_states_def
using pdo_close_under_measurement[OF dM1 dr pdor] M1leq dM1 dr by fastforce
then have dsDSM1r: "DS (M1 * ρ * adjoint M1) ∈ density_states" unfolding density_states_def DS_def
using denote_dim_pdo[OF wcs] by auto
have dM0r: "M0 * ρ * adjoint M0 ∈ carrier_mat d d" using dM0 dr by fastforce
have dDWDSM1r: "DW (DS (M1 * ρ * adjoint M1)) ∈ carrier_mat d d"
unfolding DW_def using denote_dim[OF wc] dsDSM1r density_states_def by auto
have eq2: "trace ((wlp (While M S) P) * DS (M1 * ρ * adjoint M1))
= trace (P * (DW (DS (M1 * ρ * adjoint M1)))) + trace (DS (M1 * ρ * adjoint M1)) - trace (DW (DS (M1 * ρ * adjoint M1)))"
unfolding DW_def using wlp_soundness[OF wc qpP] dsDSM1r by auto
have eq3: "trace (M1 * ρ * adjoint M1) = trace ρ - trace (M0 * ρ * adjoint M0)"
unfolding M0_def M1_def using m trace_measurement2[OF m dr] dr by (simp add: algebra_simps)
have "trace (adjoint M1 * (wlp S (wlp (While M S) P)) * M1 * ρ)
= trace ((wlp S (wlp (While M S) P)) * (M1 * ρ * adjoint M1))" using dWWP dM1 dr by (mat_assoc d)
also have "… = trace ((wlp (While M S) P) * DS (M1 * ρ * adjoint M1))
+ trace (M1 * ρ * adjoint M1) - trace (DS (M1 * ρ * adjoint M1))"
unfolding DS_def using wlp_soundness[OF wcs qpWP] dsM1r by auto
also have "… = trace (P * (DW (DS (M1 * ρ * adjoint M1))))
+ trace (M1 * ρ * adjoint M1) - trace (DW (DS (M1 * ρ * adjoint M1)))"
using eq2 by auto
also have "… = trace (P * (DW (DS (M1 * ρ * adjoint M1)))) + trace ρ - (trace (M0 * ρ * adjoint M0) + trace (DW (DS (M1 * ρ * adjoint M1))))"
using eq3 by auto
finally have eq4: "trace (adjoint M1 * (wlp S (wlp (While M S) P)) * M1 * ρ)
= trace (P * (DW (DS (M1 * ρ * adjoint M1)))) + trace ρ - (trace (M0 * ρ * adjoint M0) + trace (DW (DS (M1 * ρ * adjoint M1))))".
have "trace (adjoint M0 * P * M0 * ρ) + trace (P * (DW (DS (M1 * ρ * adjoint M1))))
= trace (P * ((M0 * ρ * adjoint M0) + (DW (DS (M1 * ρ * adjoint M1)))))"
using dP dr dM0 dDWDSM1r by (mat_assoc d)
also have "… = trace (P * (DW ρ))" unfolding DW_def M0_def M1_def DS_def using denote_while_split[OF wc dsr] by auto
finally have eq5: "trace (adjoint M0 * P * M0 * ρ) + trace (P * (DW (DS (M1 * ρ * adjoint M1)))) = trace (P * (DW ρ))".
have "trace (M0 * ρ * adjoint M0) + trace (DW (DS (M1 * ρ * adjoint M1)))
= trace (M0 * ρ * adjoint M0 + (DW (DS (M1 * ρ * adjoint M1))))"
using dr dM0 dDWDSM1r by (mat_assoc d)
also have "… = trace (DW ρ)"
unfolding DW_def DS_def M0_def M1_def denote_while_split[OF wc dsr] by auto
finally have eq6: "trace (M0 * ρ * adjoint M0) + trace (DW (DS (M1 * ρ * adjoint M1))) = trace (DW ρ)".
from eq5 eq4 eq6 have
eq7: "trace (adjoint M0 * P * M0 * ρ) + trace (adjoint M1 * wlp S (wlp (While M S) P) * M1 * ρ)
= trace (P * DW ρ) + trace ρ - trace (DW ρ)" by auto
have eq8: "trace (adjoint M0 * P * M0 * ρ) + trace (adjoint M1 * wlp S (wlp (While M S) P) * M1 * ρ)
= trace ((adjoint M0 * P * M0 + adjoint M1 * wlp S (wlp (While M S) P) * M1) * ρ)"
using dM0 dM1 dr dP dWWP by (mat_assoc d)
from eq7 eq8 have
eq9: "trace ((adjoint M0 * P * M0 + adjoint M1 * wlp S (wlp (While M S) P) * M1) * ρ) = trace (P * DW ρ) + trace ρ - trace (DW ρ)" by auto
have eq10: "trace ((wlp (While M S) P) * ρ) = trace (P * DW ρ) + trace ρ - trace (DW ρ)"
unfolding DW_def using wlp_soundness[OF wc qpP] dsr by auto
with eq9 have "trace ((wlp (While M S) P) * ρ) = trace ((adjoint M0 * P * M0 + adjoint M1 * wlp S (wlp (While M S) P) * M1) * ρ)" by auto
}
then have "(wlp (While M S) P) = (adjoint M0 * P * M0 + adjoint M1 * wlp S (wlp (While M S) P) * M1)"
using trace_pdo_eq_imp_eq[OF dWP, of "adjoint M0 * P * M0 + adjoint M1 * wlp S (wlp (While M S) P) * M1"]
dM0 dP dM1 dWWP density_states_def by fastforce
then show ?thesis using M0_def M1_def by auto
qed
lemma wlp_is_weakest_liberal_precondition:
assumes "well_com S" and "is_quantum_predicate P"
shows "is_weakest_liberal_precondition (wlp S P) S P"
unfolding is_weakest_liberal_precondition_def
proof (auto)
show qpWP: "is_quantum_predicate (wlp S P)" using wlp_close assms by auto
have eq: "trace (wlp S P * ρ) = trace (P * (denote S ρ)) + trace ρ - trace (denote S ρ)" if dsr: "ρ ∈ density_states" for ρ
using wlp_soundness assms dsr by auto
then show "⊨⇩p {wlp S P} S {P}" unfolding hoare_partial_correct_def by auto
fix Q assume qpQ: "is_quantum_predicate Q" and p: "⊨⇩p {Q} S {P}"
{
fix ρ assume dsr: "ρ ∈ density_states"
then have "trace (Q * ρ) ≤ trace (P * (denote S ρ)) + trace ρ - trace (denote S ρ)"
using hoare_partial_correct_def p by auto
then have "trace (Q * ρ) ≤ trace (wlp S P * ρ)" using eq[symmetric] dsr by auto
}
then show "Q ≤⇩L wlp S P" using lowner_le_trace density_states_def qpQ qpWP is_quantum_predicate_def by auto
qed
subsection ‹Hoare triples for partial correctness›
inductive hoare_partial :: "complex mat ⇒ com ⇒ complex mat ⇒ bool" ("⊢⇩p ({(1_)}/ (_)/ {(1_)})" 50) where
"is_quantum_predicate P ⟹ ⊢⇩p {P} SKIP {P}"
| "is_quantum_predicate P ⟹ ⊢⇩p {adjoint U * P * U} Utrans U {P}"
| "is_quantum_predicate P ⟹ is_quantum_predicate Q ⟹ is_quantum_predicate R ⟹
⊢⇩p {P} S1 {Q} ⟹ ⊢⇩p {Q} S2 {R} ⟹
⊢⇩p {P} Seq S1 S2 {R}"
| "(⋀k. k < n ⟹ is_quantum_predicate (P k)) ⟹ is_quantum_predicate Q ⟹
(⋀k. k < n ⟹ ⊢⇩p {P k} S ! k {Q}) ⟹
⊢⇩p {matrix_sum d (λk. adjoint (M k) * P k * M k) n} Measure n M S {Q}"
| "is_quantum_predicate P ⟹ is_quantum_predicate Q ⟹
⊢⇩p {Q} S {adjoint (M 0) * P * M 0 + adjoint (M 1) * Q * M 1} ⟹
⊢⇩p {adjoint (M 0) * P * M 0 + adjoint (M 1) * Q * M 1} While M S {P}"
| "is_quantum_predicate P ⟹ is_quantum_predicate Q ⟹ is_quantum_predicate P' ⟹ is_quantum_predicate Q' ⟹
P ≤⇩L P' ⟹ ⊢⇩p {P'} S {Q'} ⟹ Q' ≤⇩L Q ⟹ ⊢⇩p {P} S {Q}"
theorem hoare_partial_sound:
"⊢⇩p {P} S {Q} ⟹ well_com S ⟹ ⊨⇩p {P} S {Q}"
proof (induction rule: hoare_partial.induct)
case (1 P)
then show ?case
unfolding hoare_partial_correct_def by auto
next
case (2 P U)
then have dU: "U ∈ carrier_mat d d" and "unitary U" and dP: "P ∈ carrier_mat d d" using is_quantum_predicate_def by auto
then have uU: "adjoint U * U = 1⇩m d" using unitary_def by auto
show ?case
unfolding hoare_partial_correct_def denote.simps(2)
proof
fix ρ assume "ρ ∈ density_states"
then have dr: "ρ ∈ carrier_mat d d" using density_states_def by auto
have e1: "trace (U * ρ * adjoint U) = trace ((adjoint U * U) * ρ)"
using dr dU by (mat_assoc d)
also have "… = trace ρ"
using uU dr by auto
finally have e1: "trace (U * ρ * adjoint U) = trace ρ" .
have e2: "trace (P * (U * ρ * adjoint U)) = trace (adjoint U * P * U * ρ)"
using dU dP dr by (mat_assoc d)
with e1 have "trace (P * (U * ρ * adjoint U)) + (trace ρ - trace (U * ρ * adjoint U)) = trace (adjoint U * P * U * ρ)"
using e1 by auto
then show "trace (adjoint U * P * U * ρ) ≤ trace (P * (U * ρ * adjoint U)) + (trace ρ - trace (U * ρ * adjoint U))" by auto
qed
next
case (3 P Q R S1 S2)
then have wc1: "⊨⇩p {P} S1 {Q}" and wc2: "⊨⇩p {Q} S2 {R}" by auto
show ?case
unfolding hoare_partial_correct_def denote.simps(3)
proof clarify
fix ρ assume ρ: "ρ ∈ density_states"
have 1: "trace (P * ρ) ≤ trace (Q * denote S1 ρ) + (trace ρ - trace (denote S1 ρ))"
using wc1 hoare_partial_correct_def ρ by auto
have ρ': "denote S1 ρ ∈ density_states"
using 3(8) denote_density_states ρ by auto
have 2: "trace (Q * denote S1 ρ) ≤ trace (R * denote S2 (denote S1 ρ)) + (trace (denote S1 ρ) - trace (denote S2 (denote S1 ρ)))"
using wc2 hoare_partial_correct_def ρ' by auto
show "trace (P * ρ) ≤ trace (R * denote S2 (denote S1 ρ)) + (trace ρ - trace (denote S2 (denote S1 ρ)))"
using 1 2 by auto
qed
next
case (4 n P Q S M)
then have wc: "k < n ⟹ well_com (S!k)"
and c: "k < n ⟹ ⊨⇩p {P k} (S!k) {Q}" and m: "measurement d n M"
and dMk: "k < n ⟹ M k ∈ carrier_mat d d"
and aMMkleq: "k < n ⟹ adjoint (M k) * M k ≤⇩L 1⇩m d"
and dPk: "k < n ⟹ P k ∈ carrier_mat d d"
and dQ: "Q ∈ carrier_mat d d"
for k using is_quantum_predicate_def measurement_def measure_well_com measurement_le_one_mat by auto
{
fix ρ assume ρ: "ρ ∈ density_states"
then have dr: "ρ ∈ carrier_mat d d" and pdor: "partial_density_operator ρ" using density_states_def by auto
have dsr: "k < n ⟹ (M k) * ρ * adjoint (M k) ∈ density_states" for k unfolding density_states_def
using dMk pdo_close_under_measurement[OF dMk dr pdor aMMkleq] dr by fastforce
then have leqk: "k < n ⟹ trace ((P k) * ((M k) * ρ * adjoint (M k))) ≤
trace (Q * (denote (S!k) ((M k) * ρ * adjoint (M k)))) +
(trace ((M k) * ρ * adjoint (M k)) - trace (denote (S ! k) ((M k) * ρ * adjoint (M k))))" for k
using c unfolding hoare_partial_correct_def by auto
have "k < n ⟹ M k * ρ * adjoint (M k) ∈ carrier_mat d d" for k using dMk dr by fastforce
then have dsMrk: "k < n ⟹ matrix_sum d (λk. (M k * ρ * adjoint (M k))) k ∈ carrier_mat d d" for k
using matrix_sum_dim[of k "λk. (M k * ρ * adjoint (M k))" d] by fastforce
have "k < n ⟹ adjoint (M k) * P k * M k ∈ carrier_mat d d" for k using dMk dPk by fastforce
then have dsMP: "k < n ⟹ matrix_sum d (λk. adjoint (M k) * P k * M k) k ∈ carrier_mat d d" for k
using matrix_sum_dim[of k "λk. adjoint (M k) * P k * M k" d] by fastforce
have dSMrk: "k < n ⟹ denote (S ! k) (M k * ρ * adjoint (M k)) ∈ carrier_mat d d" for k
using denote_dim[OF wc, of k "M k * ρ * adjoint (M k)"] dsr density_states_def by fastforce
have dsSMrk: "k < n ⟹ matrix_sum d (λk. denote (S!k) (M k * ρ * adjoint (M k))) k ∈ carrier_mat d d" for k
using matrix_sum_dim[of k "λk. denote (S ! k) (M k * ρ * adjoint (M k))" d, OF dSMrk] by fastforce
have "k ≤ n ⟹
trace (matrix_sum d (λk. adjoint (M k) * P k * M k) k * ρ)
≤ trace (Q * (denote (Measure k M S) ρ)) + (trace (matrix_sum d (λk. (M k) * ρ * adjoint (M k)) k) - trace (denote (Measure k M S) ρ))" for k
unfolding denote_measure_expand[OF _ 4(5)]
proof (induct k)
case 0
then show ?case using dQ dr pdor partial_density_operator_def positive_trace by auto
next
case (Suc k)
then have k: "k < n" by auto
have eq1: "trace (matrix_sum d (λk. adjoint (M k) * P k * M k) (Suc k) * ρ)
= trace (adjoint (M k) * P k * M k * ρ) + trace (matrix_sum d (λk. adjoint (M k) * P k * M k) k * ρ)"
unfolding matrix_sum.simps
using dMk[OF k] dPk[OF k] dr dsMP[OF k] by (mat_assoc d)
have "trace (adjoint (M k) * P k * M k * ρ) = trace (P k * (M k * ρ * adjoint (M k)))"
using dMk[OF k] dPk[OF k] dr by (mat_assoc d)
also have "… ≤ trace (Q * (denote (S!k) ((M k) * ρ * adjoint (M k)))) +
(trace ((M k) * ρ * adjoint (M k)) - trace (denote (S ! k) ((M k) * ρ * adjoint (M k))))" using leqk k by auto
finally have eq2: "trace (adjoint (M k) * P k * M k * ρ) ≤ trace (Q * (denote (S!k) ((M k) * ρ * adjoint (M k)))) +
(trace ((M k) * ρ * adjoint (M k)) - trace (denote (S ! k) ((M k) * ρ * adjoint (M k))))".
have eq3: "trace (Q * matrix_sum d (λk. denote (S!k) (M k * ρ * adjoint (M k))) (Suc k))
= trace (Q * (denote (S!k) (M k * ρ * adjoint (M k)))) + trace (Q * matrix_sum d (λk. denote (S!k) (M k * ρ * adjoint (M k))) k)"
unfolding matrix_sum.simps
using dQ dSMrk[OF k] dsSMrk[OF k] by (mat_assoc d)
have eq4: "trace (denote (S ! k) (M k * ρ * adjoint (M k)) + matrix_sum d (λk. denote (S!k) (M k * ρ * adjoint (M k))) k)
= trace (denote (S ! k) (M k * ρ * adjoint (M k))) + trace (matrix_sum d (λk. denote (S!k) (M k * ρ * adjoint (M k))) k)"
using dSMrk[OF k] dsSMrk[OF k] by (mat_assoc d)
show ?case
apply (subst eq1) apply (subst eq3)
apply (simp del: less_eq_complex_def)
apply (subst trace_add_linear[of "M k * ρ * adjoint (M k)" d "matrix_sum d (λk. M k * ρ * adjoint (M k)) k"])
apply (simp add: dMk adjoint_dim[OF dMk] dr mult_carrier_mat[of _ d d _ d] k)
apply (simp add: dsMrk k)
apply (subst eq4)
apply (insert eq2 Suc(1) k, fastforce)
done
qed
then have leq: "trace (matrix_sum d (λk. adjoint (M k) * P k * M k) n * ρ)
≤ trace (Q * denote (Measure n M S) ρ) +
(trace (matrix_sum d (λk. (M k) * ρ * adjoint (M k)) n) - trace (denote (Measure n M S) ρ))"
by auto
have "trace (matrix_sum d (λk. (M k) * ρ * adjoint (M k)) n) = trace ρ" using trace_measurement m dr by auto
with leq have "trace (matrix_sum d (λk. adjoint (M k) * P k * M k) n * ρ)
≤ trace (Q * denote (Measure n M S) ρ) + (trace ρ - trace (denote (Measure n M S) ρ))"
unfolding denote_measure_def by auto
}
then show ?case unfolding hoare_partial_correct_def by auto
next
case (5 P Q S M)
define M0 where "M0 = M 0"
define M1 where "M1 = M 1"
from 5 have wcs: "well_com S" and c: "⊨⇩p {Q} S {adjoint M0 * P * M0 + adjoint M1 * Q * M1}"
and m: "measurement d 2 M"
and dM0: "M0 ∈ carrier_mat d d" and dM1: "M1 ∈ carrier_mat d d"
and dP: "P ∈ carrier_mat d d" and dQ: "Q ∈ carrier_mat d d"
and qpQ: "is_quantum_predicate Q"
and wc: "well_com (While M S)"
using measurement_def is_quantum_predicate_def M0_def M1_def by auto
then have M0leq: "adjoint M0 * M0 ≤⇩L 1⇩m d" and M1leq: "adjoint M1 * M1 ≤⇩L 1⇩m d" using measurement_le_one_mat[OF m] M0_def M1_def by auto
define DS where "DS = denote S"
have "∀ρ ∈ density_states. trace (Q * ρ) ≤ trace ((adjoint M0 * P * M0 + adjoint M1 * Q * M1) * DS ρ) + trace ρ - trace (DS ρ)"
using hoare_partial_correct_def[of Q S "adjoint M0 * P * M0 + adjoint M1 * Q * M1"] c DS_def by auto
define D0 where "D0 = denote_while_n M0 M1 DS"
define D1 where "D1 = denote_while_n_comp M0 M1 DS"
define D where "D = denote_while_n_iter M0 M1 DS"
{
fix ρ assume dsr: "ρ ∈ density_states"
then have dr: "ρ ∈ carrier_mat d d" and pr: "positive ρ" and pdor: "partial_density_operator ρ"
using density_states_def partial_density_operator_def by auto
have pdoDkr: "⋀k. partial_density_operator (D k ρ)" unfolding D_def
using pdo_denote_while_n_iter[OF dr pdor dM1 M1leq]
denote_partial_density_operator[OF wcs] denote_dim[OF wcs, folded DS_def]
apply (fold DS_def) by auto
then have pDkr: "⋀k. positive (D k ρ)" unfolding partial_density_operator_def by auto
have dDkr: "⋀k. D k ρ ∈ carrier_mat d d"
using denote_while_n_iter_dim[OF dr pdor dM1 M1leq denote_dim_pdo[OF wcs, folded DS_def], of id M0, simplified, folded D_def] by auto
then have dD0kr: "⋀k. D0 k ρ ∈ carrier_mat d d" unfolding D0_def denote_while_n.simps apply (fold D_def) using dM0 by auto
then have dPD0kr: "⋀k. P * (D0 k ρ) ∈ carrier_mat d d" using dP by auto
have "⋀k. positive (D0 k ρ)" unfolding D0_def denote_while_n.simps
by (fold D_def, rule positive_close_under_left_right_mult_adjoint[OF dM0 dDkr pDkr])
then have trge0: "⋀k. trace (D0 k ρ) ≥ 0" using positive_trace dD0kr by blast
have DSr: "ρ ∈ density_states ⟹ DS ρ ∈ density_states" for "ρ" unfolding DS_def density_states_def
using denote_partial_density_operator denote_dim wcs by auto
have dsD1nr: "D1 n ρ ∈ density_states" for n unfolding D1_def denote_while_n_comp.simps
apply (fold D_def) unfolding density_states_def
apply (auto)
apply (insert dDkr dM1 adjoint_dim[OF dM1], auto)
apply (rule pdo_close_under_measurement[OF dM1 spec[OF allI[OF dDkr], of "λx. n"] spec[OF allI[OF pdoDkr], of "λx. n"] M1leq])
done
have leQn: "trace (Q * D1 n ρ)
≤ trace (P * D0 (Suc n) ρ) + trace (Q * D1 (Suc n) ρ)
+ trace (D1 n ρ) - trace (D (Suc n) ρ)" for n
proof -
have "(∀ρ∈density_states. trace (Q * ρ) ≤ trace ((adjoint M0 * P * M0 + adjoint M1 * Q * M1) * denote S ρ) + (trace ρ - trace (denote S ρ)))"
using c hoare_partial_correct_def by auto
then have leQn': "trace (Q * (D1 n ρ))
≤ trace ((adjoint M0 * P * M0 + adjoint M1 * Q * M1) * (DS (D1 n ρ)))
+ (trace (D1 n ρ) - trace (DS (D1 n ρ)))"
using dsD1nr[of n] DS_def by auto
have "(DS (D1 n ρ)) ∈ carrier_mat d d" unfolding DS_def using denote_dim[OF wcs] dsD1nr density_states_def by auto
then have "trace ((adjoint M0 * P * M0 + adjoint M1 * Q * M1) * (DS (D1 n ρ)))
= trace (P * (M0 * (DS (D1 n ρ)) * adjoint M0))
+ trace (Q * (M1 * (DS (D1 n ρ)) * adjoint M1))" using dP dQ dM0 dM1 by (mat_assoc d)
moreover have "trace (P * (M0 * (DS (D1 n ρ)) * adjoint M0)) = trace (P * D0 (Suc n) ρ)"
unfolding D0_def denote_while_n.simps
apply (subst denote_while_n_iter_assoc)
by (fold denote_while_n_comp.simps D1_def, auto)
moreover have "trace (Q * (M1 * (DS (D1 n ρ)) * adjoint M1)) = trace (Q * D1 (Suc n) ρ)"
apply (subst (2) D1_def) unfolding denote_while_n_comp.simps
apply (subst denote_while_n_iter_assoc)
by (fold denote_while_n_comp.simps D1_def, auto)
ultimately have "trace ((adjoint M0 * P * M0 + adjoint M1 * Q * M1) * (DS (D1 n ρ)))
= trace (P * D0 (Suc n) ρ) + trace (Q * D1 (Suc n) ρ)" by auto
moreover have "trace (DS (D1 n ρ)) = trace (D (Suc n) ρ)"
unfolding D_def
apply (subst denote_while_n_iter_assoc)
by (fold denote_while_n_comp.simps D1_def, auto)
ultimately show ?thesis using leQn' by auto
qed
have 12: "trace (P * (M0 * ρ * adjoint M0)) + trace (Q * (M1 * ρ * adjoint M1))
≤ (∑k=0..<(n+2). trace (P * (D0 k ρ))) + trace (Q * (D1 (n+1) ρ))
+ (∑k=0..<(n+1). trace (D1 k ρ) - trace (D (k+1) ρ))" for n
proof (induct n)
case 0
show ?case apply (simp del: less_eq_complex_def)
unfolding D0_def D1_def D_def denote_while_n_comp.simps denote_while_n.simps denote_while_n_iter.simps
using leQn[of 0] unfolding D1_def D0_def D_def denote_while_n.simps denote_while_n_comp.simps denote_while_n_iter.simps by auto
next
case (Suc n)
have "trace (Q * D1 (n + 1) ρ)
≤ trace (P * D0 (Suc (Suc n)) ρ) + trace (Q * D1 (Suc (Suc n)) ρ)
+ trace (D1 (Suc n) ρ) - trace (D (Suc (Suc n)) ρ)" using leQn[of "n + 1"] by auto
with Suc show ?case apply (simp del: less_eq_complex_def) by auto
qed
have tr_measurement: "ρ ∈ carrier_mat d d
⟹ trace (M0 * ρ * adjoint M0) + trace (M1 * ρ * adjoint M1) = trace ρ" for ρ
using trace_measurement2[OF m, folded M0_def M1_def] by auto
have 14: "(∑k=0..<(n+1). trace (D1 k ρ) - trace (D (k+1) ρ)) = trace ρ - trace (D (n+1) ρ) - (∑k=0..<(n+1). trace (D0 k ρ))" for n
proof (induct n)
case 0
show ?case apply (simp) unfolding D1_def D0_def denote_while_n_comp.simps denote_while_n.simps denote_while_n_iter.simps
using tr_measurement[OF dr] by (auto simp add: algebra_simps)
next
case (Suc n)
have "trace (D0 (Suc n) ρ) + trace (D1 (Suc n) ρ) = trace (D (Suc n) ρ)"
unfolding D0_def D1_def denote_while_n.simps denote_while_n_comp.simps apply (fold D_def)
using tr_measurement dDkr by auto
then have "trace (D1 (Suc n) ρ) = trace (D (Suc n) ρ) - trace (D0 (Suc n) ρ)"
by (auto simp add: algebra_simps)
then show ?case using Suc by simp
qed
have 15: "trace (Q * (D1 n ρ)) ≤ trace (D n ρ) - trace (D0 n ρ)" for n
proof -
have QleId: "Q ≤⇩L 1⇩m d" using is_quantum_predicate_def qpQ by auto
then have "trace (Q * (D1 n ρ)) ≤ trace (1⇩m d * (D1 n ρ))" using
dsD1nr[of n] unfolding density_states_def lowner_le_trace[OF dQ one_carrier_mat] by auto
also have "… = trace (D1 n ρ)" using dsD1nr[of n] unfolding density_states_def by auto
also have "… = trace (M1 * (D n ρ) * adjoint M1)" unfolding D1_def denote_while_n_comp.simps D_def by auto
also have "… = trace (D n ρ) - trace (M0 * (D n ρ) * adjoint M0)"
using tr_measurement[OF dDkr[of n]] by (simp add: algebra_simps)
also have "… = trace (D n ρ) - trace (D0 n ρ)" unfolding D0_def denote_while_n.simps by (fold D_def, auto)
finally show ?thesis.
qed
have tmp: "⋀a b c. 0 ≤ a ⟹ b ≤ c - a ⟹ b ≤ (c::complex)" by simp
then have 151: "⋀n. trace (Q * (D1 n ρ)) ≤ trace (D n ρ)"
by (auto simp add: tmp[OF trge0 15] simp del: less_eq_complex_def)
have main_leq: "⋀n. trace (P * (M0 * ρ * adjoint M0)) + trace (Q * (M1 * ρ * adjoint M1))
≤ trace (P * (matrix_sum d (λk. D0 k ρ) (n+2))) + trace ρ - trace (matrix_sum d (λk. D0 k ρ) (n+2))"
proof -
fix n
have "(∑k=0..<(n+2). trace (P * (D0 k ρ))) + trace (Q * (D1 (n+1) ρ))
+ (∑k=0..<(n+1). trace (D1 k ρ) - trace (D (k+1) ρ))
≤ (∑k=0..<(n+2). trace (P * (D0 k ρ))) + trace (Q * (D1 (n+1) ρ))
+ trace ρ - trace (D (n+1) ρ) - (∑k=0..<(n+1). trace (D0 k ρ))"
by (subst 14, auto)
also have
"… ≤ (∑k=0..<(n+2). trace (P * (D0 k ρ))) + trace (D (n+1) ρ) - trace (D0 (n+1) ρ)
+ trace ρ - trace (D (n+1) ρ) - (∑k=0..<(n+1). trace (D0 k ρ))"
using 15[of "n+1"] by auto
also have "… = (∑k=0..<(n+2). trace (P * (D0 k ρ))) + trace ρ - (∑k=0..<(n+2). trace (D0 k ρ))" by auto
also have "… = trace (matrix_sum d (λk. (P * (D0 k ρ))) (n+2)) + trace ρ - (∑k=0..<(n+2). trace (D0 k ρ))"
using trace_matrix_sum_linear[of "n+2" "λk. (P * (D0 k ρ))" d, symmetric] dPD0kr by auto
also have "… = trace (matrix_sum d (λk. (P * (D0 k ρ))) (n+2)) + trace ρ - trace (matrix_sum d (λk. D0 k ρ) (n+2))"
using trace_matrix_sum_linear[of "n+2" "λk. D0 k ρ" d, symmetric] dD0kr by auto
also have "… = trace (P * (matrix_sum d (λk. D0 k ρ) (n+2))) + trace ρ - trace (matrix_sum d (λk. D0 k ρ) (n+2))"
using matrix_sum_distrib_left[OF dP dD0kr, of id "n+2"] by auto
finally have
"(∑k=0..<(n+2). trace (P * (D0 k ρ))) + trace (Q * (D1 (n+1) ρ))
+ (∑k=0..<(n+1). trace (D1 k ρ) - trace (D (k+1) ρ))
≤ trace (P * (matrix_sum d (λk. D0 k ρ) (n+2))) + trace ρ - trace (matrix_sum d (λk. D0 k ρ) (n+2))" .
then show "trace (P * (M0 * ρ * adjoint M0)) + trace (Q * (M1 * ρ * adjoint M1))
≤ trace (P * (matrix_sum d (λk. D0 k ρ) (n+2))) + trace ρ - trace (matrix_sum d (λk. D0 k ρ) (n+2))" using 12[of n] by auto
qed
have "limit_mat (λn. matrix_sum d (λk. D0 k ρ) (n)) (denote (While M S) ρ) d"
using limit_mat_denote_while_n[OF wc dr pdor] unfolding D0_def M0_def M1_def DS_def by auto
then have limp2: "limit_mat (λn. matrix_sum d (λk. D0 k ρ) (n + 2)) (denote (While M S) ρ) d"
using limit_mat_ignore_initial_segment[of "λn. matrix_sum d (λk. D0 k ρ) (n)" "(denote (While M S) ρ)" d 2] by auto
then have "limit_mat (λn. (P * (matrix_sum d (λk. D0 k ρ) (n+2)))) (P * (denote (While M S) ρ)) d"
using mat_mult_limit[OF dP] unfolding mat_mult_seq_def by auto
then have limPm: "(λn. trace (P * (matrix_sum d (λk. D0 k ρ) (n+2)))) ⇢ trace (P * (denote (While M S) ρ))"
using mat_trace_limit by auto
have limm: "(λn. trace (matrix_sum d (λk. D0 k ρ) (n+2))) ⇢ trace (denote (While M S) ρ)"
using mat_trace_limit limp2 by auto
have leq_lim: "trace (P * (M0 * ρ * adjoint M0)) + trace (Q * (M1 * ρ * adjoint M1))
≤ trace (P * (denote (While M S) ρ)) + trace ρ - trace (denote (While M S) ρ)" (is "?lhs ≤ ?rhs")
using main_leq
proof -
define seq where "seq n = trace (P * matrix_sum d (λk. D0 k ρ) (n + 2)) - trace (matrix_sum d (λk. D0 k ρ) (n + 2)) " for n
define seqlim where "seqlim = trace (P * (denote (While M S) ρ)) - trace (denote (While M S) ρ)"
have main_leq': "?lhs ≤ trace ρ + seq n" for n
unfolding seq_def using main_leq by (simp add: algebra_simps)
have limseq: "seq ⇢ seqlim"
unfolding seq_def seqlim_def using tendsto_diff[OF limPm limm] by auto
have limrs: "(λn. trace ρ + seq n) ⇢ (trace ρ + seqlim)" using tendsto_add[OF _ limseq] by auto
have limrsRe: "(λn. Re (trace ρ + seq n)) ⇢ Re (trace ρ + seqlim)" using tendsto_Re[OF limrs] by auto
have main_leq_Re: "Re ?lhs ≤ Re (trace ρ + seq n)" for n using main_leq' by auto
have Re: "Re ?lhs ≤ Re (trace ρ + seqlim)"
using Lim_bounded2[OF limrsRe ] main_leq_Re by auto
have limrsIm: "(λn. Im (trace ρ + seq n)) ⇢ Im (trace ρ + seqlim)" using tendsto_Im[OF limrs] by auto
have main_leq_Im: "Im ?lhs = Im (trace ρ + seq n)" for n using main_leq' unfolding less_eq_complex_def by auto
then have limIm: "(λn. Im (trace ρ + seq n)) ⇢ Im ?lhs" using tendsto_intros(1) by auto
have Im: "Im ?lhs = Im (trace ρ + seqlim)"
using tendsto_unique[OF _ limIm limrsIm] by auto
have "?lhs ≤ trace ρ + seqlim" using Re Im by auto
then show "?lhs ≤ ?rhs" unfolding seqlim_def by auto
qed
have "trace ((adjoint M0 * P * M0 + adjoint M1 * Q * M1) * ρ) =
trace (P * (M0 * ρ * adjoint M0)) + trace (Q * (M1 * ρ * adjoint M1))"
using dr dM0 dM1 dP dQ by (mat_assoc d)
then have "trace ((adjoint M0 * P * M0 + adjoint M1 * Q * M1) * ρ) ≤
trace (P * (denote (While M S) ρ)) + (trace ρ - trace (denote (While M S) ρ))"
using leq_lim by auto
}
then show ?case unfolding hoare_partial_correct_def denote.simps(5)
apply (fold M0_def M1_def DS_def D0_def D1_def) by auto
next
case (6 P Q P' Q' S)
then have wcs: "well_com S" and c: "⊨⇩p {P'} S {Q'}"
and dP: "P ∈ carrier_mat d d" and dQ: "Q ∈ carrier_mat d d"
and dP': "P' ∈ carrier_mat d d" and dQ': "Q' ∈ carrier_mat d d"
using is_quantum_predicate_def by auto
show ?case unfolding hoare_partial_correct_def
proof
fix ρ assume pds: "ρ ∈ density_states"
then have pdor: "partial_density_operator ρ" and dr: "ρ ∈ carrier_mat d d"
using density_states_def by auto
have pdoSr: "partial_density_operator (denote S ρ)"
using denote_partial_density_operator pdor dr wcs by auto
have dSr: "denote S ρ ∈ carrier_mat d d"
using denote_dim pdor dr wcs by auto
have "trace (P * ρ) ≤ trace (P' * ρ)" using lowner_le_trace[OF dP dP'] 6 dr pdor by auto
also have "… ≤ trace (Q' * denote S ρ) + (trace ρ - trace (denote S ρ))"
using c unfolding hoare_partial_correct_def using pds by auto
also have "… ≤ trace (Q * denote S ρ) + (trace ρ - trace (denote S ρ))" using lowner_le_trace[OF dQ' dQ] 6 dSr pdoSr by auto
finally show "trace (P * ρ) ≤ trace (Q * denote S ρ) + (trace ρ - trace (denote S ρ)) ".
qed
qed
lemma wlp_complete:
"well_com S ⟹ is_quantum_predicate P ⟹ ⊢⇩p {wlp S P} S {P}"
proof (induct S arbitrary: P)
case SKIP
then show ?case unfolding wlp.simps using hoare_partial.intros by auto
next
case (Utrans U)
then show ?case unfolding wlp.simps using hoare_partial.intros by auto
next
case (Seq S1 S2)
then have wc1: "well_com S1" and wc2: "well_com S2" and qpP: "is_quantum_predicate P"
and p2: "⊢⇩p {wlp S2 P} S2 {P}" by auto
have qpW2P: "is_quantum_predicate (wlp S2 P)" using wlp_close[OF wc2 qpP] by auto
then have p1: "⊢⇩p {wlp S1 (wlp S2 P)} S1 {wlp S2 P}" using Seq by auto
have qpW1W2P: "is_quantum_predicate (wlp S1 (wlp S2 P))" using wlp_close[OF wc1 qpW2P] by auto
then show ?case unfolding wlp.simps using hoare_partial.intros qpW1W2P qpW2P qpP p1 p2 by auto
next
case (Measure n M S)
then have wc: "well_com (Measure n M S)" and qpP: "is_quantum_predicate P" by auto
have set: "k < n ⟹ (S!k) ∈ set S" for k using wc by auto
have wck: "k < n ⟹ well_com (S!k)" for k using wc measure_well_com by auto
then have qpWkP: "k < n ⟹ is_quantum_predicate (wlp (S!k) P)" for k using wlp_close qpP by auto
have pk: "k < n ⟹ ⊢⇩p {(wlp (S!k) P)} (S!k) {P}" for k using Measure(1) set wck qpP by auto
show ?case unfolding wlp_measure_expand[OF wc] using hoare_partial.intros qpWkP qpP pk by auto
next
case (While M S)
then have wc: "well_com (While M S)" and wcS: "well_com S" and qpP: "is_quantum_predicate P " by auto
have qpWP: "is_quantum_predicate (wlp (While M S) P)" using wlp_close[OF wc qpP] by auto
then have qpWWP: "is_quantum_predicate (wlp S (wlp (While M S) P))" using wlp_close wcS by auto
have "⊢⇩p {wlp S (wlp (While M S) P)} S {wlp (While M S) P}" using While(1) wcS qpWP by auto
moreover have eq: "wlp (While M S) P = adjoint (M 0) * P * M 0 + adjoint (M 1) * wlp S (wlp (While M S) P) * M 1"
using wlp_while_split wc qpP by auto
ultimately have p: "⊢⇩p {wlp S (wlp (While M S) P)} S {adjoint (M 0) * P * M 0 + adjoint (M 1) * wlp S (wlp (While M S) P) * M 1}" by auto
then show ?case using hoare_partial.intros(5)[OF qpP qpWWP p] eq by auto
qed
theorem hoare_partial_complete:
"⊨⇩p {P} S {Q} ⟹ well_com S ⟹ is_quantum_predicate P ⟹ is_quantum_predicate Q ⟹ ⊢⇩p {P} S {Q}"
proof -
assume p: "⊨⇩p {P} S {Q}" and wc: "well_com S" and qpP: "is_quantum_predicate P" and qpQ: "is_quantum_predicate Q"
then have dQ: "Q ∈ carrier_mat d d" using is_quantum_predicate_def by auto
have qpWP: "is_quantum_predicate (wlp S Q)" using wlp_close wc qpQ by auto
then have dWP: "wlp S Q ∈ carrier_mat d d" using is_quantum_predicate_def by auto
have eq: "trace (wlp S Q * ρ) = trace (Q * (denote S ρ)) + trace ρ - trace (denote S ρ)" if dsr: "ρ ∈ density_states" for ρ
using wlp_soundness wc qpQ dsr by auto
then have "⊨⇩p {wlp S Q} S {Q}" unfolding hoare_partial_correct_def by auto
{
fix ρ assume dsr: "ρ ∈ density_states"
then have "trace (P * ρ) ≤ trace (Q * (denote S ρ)) + trace ρ - trace (denote S ρ)"
using hoare_partial_correct_def p by auto
then have "trace (P * ρ) ≤ trace (wlp S Q * ρ)" using eq[symmetric] dsr by auto
}
then have le: "P ≤⇩L wlp S Q" using lowner_le_trace density_states_def qpP qpWP is_quantum_predicate_def by auto
moreover have wlp: "⊢⇩p {wlp S Q} S {Q}" using wlp_complete wc qpQ by auto
ultimately show "⊢⇩p {P} S {Q}" using hoare_partial.intros(6)[OF qpP qpQ qpWP qpQ] lowner_le_refl[OF dQ] by auto
qed
subsection ‹Consequences of completeness›
lemma hoare_patial_seq_assoc_sem:
shows "⊨⇩p {A} (S1 ;; S2) ;; S3 {B} ⟷ ⊨⇩p {A} S1 ;; (S2 ;; S3) {B}"
unfolding hoare_partial_correct_def denote.simps by auto
lemma hoare_patial_seq_assoc:
assumes "well_com S1" and "well_com S2" and "well_com S3"
and "is_quantum_predicate A" and "is_quantum_predicate B"
shows "⊢⇩p {A} (S1 ;; S2) ;; S3 {B} ⟷ ⊢⇩p {A} S1 ;; (S2 ;; S3) {B}"
proof
assume "⊢⇩p {A} S1;; S2;; S3 {B}"
then have "⊨⇩p {A} (S1 ;; S2) ;; S3 {B}" using hoare_partial_sound assms by auto
then have "⊨⇩p {A} S1 ;; (S2 ;; S3) {B}" using hoare_patial_seq_assoc_sem by auto
then show "⊢⇩p {A} S1 ;; (S2 ;; S3) {B}" using hoare_partial_complete assms by auto
next
assume "⊢⇩p {A} S1;; (S2;; S3) {B}"
then have "⊨⇩p {A} S1;; (S2;; S3) {B}" using hoare_partial_sound assms by auto
then have "⊨⇩p {A} S1;; S2;; S3 {B}" using hoare_patial_seq_assoc_sem by auto
then show "⊢⇩p {A} S1;; S2;; S3 {B}" using hoare_partial_complete assms by auto
qed
end
end
Theory Grover
section ‹Grover's algorithm›
theory Grover
imports Partial_State Gates Quantum_Hoare
begin
subsection ‹Basic definitions›
locale grover_state =
fixes n :: nat
and f :: "nat ⇒ bool"
assumes n: "n > 1"
and dimM: "card {i. i < (2::nat) ^ n ∧ f i} > 0"
"card {i. i < (2::nat) ^ n ∧ f i} < (2::nat) ^ n"
begin
definition N where
"N = (2::nat) ^ n"
definition M where
"M = card {i. i < N ∧ f i}"
lemma N_ge_0 [simp]: "0 < N" by (simp add: N_def)
lemma M_ge_0 [simp]: "0 < M" by (simp add: M_def dimM N_def)
lemma M_neq_0 [simp]: "M ≠ 0" by simp
lemma M_le_N [simp]: "M < N" by (simp add: M_def dimM N_def)
lemma M_not_ge_N [simp]: "¬ M ≥ N" using M_le_N by arith
definition ψ :: "complex vec" where
"ψ = Matrix.vec N (λi. 1 / sqrt N)"
lemma ψ_dim [simp]:
"ψ ∈ carrier_vec N"
"dim_vec ψ = N"
by (simp add: ψ_def)+
lemma ψ_eval:
"i < N ⟹ ψ $ i = 1 / sqrt N"
by (simp add: ψ_def)
lemma ψ_inner:
"inner_prod ψ ψ = 1"
apply (simp add: ψ_eval scalar_prod_def)
by (smt of_nat_less_0_iff of_real_mult of_real_of_nat_eq real_sqrt_mult_self)
lemma ψ_norm:
"vec_norm ψ = 1"
by (simp add: ψ_eval vec_norm_def scalar_prod_def)
definition α :: "complex vec" where
"α = Matrix.vec N (λi. if f i then 0 else 1 / sqrt (N - M))"
lemma α_dim [simp]:
"α ∈ carrier_vec N"
"dim_vec α = N"
by (simp add: α_def)+
lemma α_eval:
"i < N ⟹ α $ i = (if f i then 0 else 1 / sqrt (N - M))"
by (simp add: α_def)
lemma α_inner:
"inner_prod α α = 1"
apply (simp add: scalar_prod_def α_eval)
apply (subst sum.mono_neutral_cong_right[of "{0..<N}" "{0..<N}-{i. i < N ∧ f i}"])
apply auto
apply (subgoal_tac "card ({0..<N} - {i. i < N ∧ f i}) = N - M")
subgoal by (metis of_nat_0_le_iff of_real_of_nat_eq of_real_power power2_eq_square real_sqrt_pow2)
unfolding N_def M_def
by (metis (no_types, lifting) atLeastLessThan_iff card.infinite card_Diff_subset card_atLeastLessThan diff_zero dimM(1) mem_Collect_eq neq0_conv subsetI zero_order(1))
definition β :: "complex vec" where
"β = Matrix.vec N (λi. if f i then 1 / sqrt M else 0)"
lemma β_dim [simp]:
"β ∈ carrier_vec N"
"dim_vec β = N"
by (simp add: β_def)+
lemma β_eval:
"i < N ⟹ β $ i = (if f i then 1 / sqrt M else 0)"
by (simp add: β_def)
lemma β_inner:
"inner_prod β β = 1"
apply (simp add: scalar_prod_def β_eval)
apply (subst sum.mono_neutral_cong_right[of "{0..<N}" "{i. i < N ∧ f i}"])
apply auto
apply (fold M_def)
by (metis of_nat_0_le_iff of_real_of_nat_eq of_real_power power2_eq_square real_sqrt_pow2)
lemma alpha_beta_orth:
"inner_prod α β = 0"
unfolding α_def β_def by (simp add: scalar_prod_def)
lemma beta_alpha_orth:
"inner_prod β α = 0"
unfolding α_def β_def by (simp add: scalar_prod_def)
definition θ :: real where
"θ = 2 * arccos (sqrt ((N - M) / N))"
lemma cos_theta_div_2:
"cos (θ / 2) = sqrt ((N - M) / N)"
proof -
have "θ / 2 = arccos (sqrt ((N - M) / N))" using θ_def by simp
then show "cos (θ / 2) = sqrt ((N - M) / N)"
by (simp add: cos_arccos_abs)
qed
lemma sin_theta_div_2:
"sin (θ / 2) = sqrt (M / N)"
proof -
have a: "θ / 2 = arccos (sqrt ((N - M) / N))" using θ_def by simp
have N: "N > 0" using N_def by auto
have M: "M < N" using M_def dimM N_def by auto
then show "sin (θ / 2) = sqrt (M / N)"
unfolding a
apply (simp add: sin_arccos_abs)
proof -
have eq: "real (N - M) = real N - real M" using N M
using M_not_ge_N nat_le_linear of_nat_diff by blast
have "1 - real (N - M) / real N = (real N - (real N - real M)) / real N"
unfolding eq using N
by (metis diff_divide_distrib divide_self_if eq gr_implies_not0 of_nat_0_eq_iff)
then show "1 - real (N - M) / real N = real M / real N" by auto
qed
qed
lemma θ_neq_0:
"θ ≠ 0"
proof -
{
assume "θ = 0"
then have "θ / 2 = 0" by auto
then have "sin (θ / 2) = 0" by auto
}
note z = this
have "sin (θ / 2) = sqrt (M / N)" using sin_theta_div_2 by auto
moreover have "M > 0" unfolding M_def N_def using dimM by auto
ultimately have "sin (θ / 2) > 0" by auto
with z show ?thesis by auto
qed
abbreviation ccos where "ccos φ ≡ complex_of_real (cos φ)"
abbreviation csin where "csin φ ≡ complex_of_real (sin φ)"
lemma ψ_eq:
"ψ = ccos (θ / 2) ⋅⇩v α + csin (θ / 2) ⋅⇩v β"
apply (simp add: cos_theta_div_2 sin_theta_div_2)
apply (rule eq_vecI)
by (auto simp add: α_def β_def ψ_def real_sqrt_divide)
lemma psi_inner_alpha:
"inner_prod ψ α = ccos (θ / 2)"
unfolding ψ_eq
proof -
have "inner_prod (ccos (θ / 2) ⋅⇩v α) α = ccos (θ / 2)"
apply (subst inner_prod_smult_right[of _ N])
using α_dim α_inner by auto
moreover have "inner_prod (csin (θ / 2) ⋅⇩v β) α = 0"
apply (subst inner_prod_smult_right[of _ N])
using α_dim β_dim beta_alpha_orth by auto
ultimately show "inner_prod (ccos (θ / 2) ⋅⇩v α + csin (θ / 2) ⋅⇩v β) α = ccos (θ / 2)"
apply (subst inner_prod_distrib_left[of _ N])
using α_dim β_dim by auto
qed
lemma psi_inner_beta:
"inner_prod ψ β = csin (θ / 2)"
unfolding ψ_eq
proof -
have "inner_prod (ccos (θ / 2) ⋅⇩v α) β = 0"
apply (subst inner_prod_smult_right[of _ N])
using α_dim β_dim alpha_beta_orth by auto
moreover have "inner_prod (csin (θ / 2) ⋅⇩v β) β = csin (θ / 2)"
apply (subst inner_prod_smult_right[of _ N])
using β_dim β_inner by auto
ultimately show "inner_prod (ccos (θ / 2) ⋅⇩v α + csin (θ / 2) ⋅⇩v β) β = csin (θ / 2)"
apply (subst inner_prod_distrib_left[of _ N])
using α_dim β_dim by auto
qed
definition alpha_l :: "nat ⇒ complex" where
"alpha_l l = ccos ((l + 1 / 2) * θ)"
lemma alpha_l_real:
"alpha_l l ∈ Reals"
unfolding alpha_l_def by auto
lemma cnj_alpha_l:
"conjugate (alpha_l l) = alpha_l l"
using alpha_l_real Reals_cnj_iff by auto
definition beta_l :: "nat ⇒ complex" where
"beta_l l = csin ((l + 1 / 2) * θ)"
lemma beta_l_real:
"beta_l l ∈ Reals"
unfolding beta_l_def by auto
lemma cnj_beta_l:
"conjugate (beta_l l) = beta_l l"
using beta_l_real Reals_cnj_iff by auto
lemma csin_ccos_squared_add:
"ccos (a::real) * ccos a + csin a * csin a = 1"
by (smt cos_diff cos_zero of_real_add of_real_hom.hom_one of_real_mult)
lemma alpha_l_beta_l_add_norm:
"alpha_l l * alpha_l l + beta_l l * beta_l l = 1"
using alpha_l_def beta_l_def csin_ccos_squared_add by auto
definition psi_l where
"psi_l l = (alpha_l l) ⋅⇩v α + (beta_l l) ⋅⇩v β"
lemma psi_l_dim:
"psi_l l ∈ carrier_vec N"
unfolding psi_l_def α_def β_def by auto
lemma inner_psi_l:
"inner_prod (psi_l l) (psi_l l) = 1"
proof -
have eq0: "inner_prod (psi_l l) (psi_l l)
= inner_prod ((alpha_l l) ⋅⇩v α) (psi_l l) + inner_prod ((beta_l l) ⋅⇩v β) (psi_l l)"
unfolding psi_l_def
apply (subst inner_prod_distrib_left)
using α_def β_def by auto
have "inner_prod ((alpha_l l) ⋅⇩v α) (psi_l l)
= inner_prod ((alpha_l l) ⋅⇩v α) ((alpha_l l) ⋅⇩v α) + inner_prod ((alpha_l l) ⋅⇩v α) ((beta_l l) ⋅⇩v β)"
unfolding psi_l_def
apply (subst inner_prod_distrib_right)
using α_def β_def by auto
also have "… = (conjugate (alpha_l l)) * (alpha_l l) * inner_prod α α
+ (conjugate (alpha_l l)) * (beta_l l) * inner_prod α β"
apply (subst (1 2) inner_prod_smult_left_right) using α_def β_def by auto
also have "… = conjugate (alpha_l l) * (alpha_l l) "
by (simp add: alpha_beta_orth α_inner)
also have "… = (alpha_l l) * (alpha_l l)" using cnj_alpha_l by simp
finally have eq1: "inner_prod (alpha_l l ⋅⇩v α) (psi_l l) = alpha_l l * alpha_l l".
have "inner_prod ((beta_l l) ⋅⇩v β) (psi_l l)
= inner_prod ((beta_l l) ⋅⇩v β) ((alpha_l l) ⋅⇩v α) + inner_prod ((beta_l l) ⋅⇩v β) ((beta_l l) ⋅⇩v β)"
unfolding psi_l_def
apply (subst inner_prod_distrib_right)
using α_def β_def by auto
also have "… = (conjugate (beta_l l)) * (alpha_l l) * inner_prod β α
+ (conjugate (beta_l l)) * (beta_l l) * inner_prod β β"
apply (subst (1 2) inner_prod_smult_left_right) using α_def β_def by auto
also have "… = (conjugate (beta_l l)) * (beta_l l)" using β_inner beta_alpha_orth by auto
also have "… = (beta_l l) * (beta_l l)" using cnj_beta_l by auto
finally have eq2: "inner_prod (beta_l l ⋅⇩v β) (psi_l l) = beta_l l * beta_l l".
show ?thesis unfolding eq0 eq1 eq2 using alpha_l_beta_l_add_norm by auto
qed
abbreviation proj :: "complex vec ⇒ complex mat" where
"proj v ≡ outer_prod v v"
definition psi'_l where
"psi'_l l = (alpha_l l) ⋅⇩v α - (beta_l l) ⋅⇩v β"
lemma psi'_l_dim:
"psi'_l l ∈ carrier_vec N"
unfolding psi'_l_def α_def β_def by auto
definition proj_psi'_l where
"proj_psi'_l l = proj (psi'_l l)"
lemma proj_psi'_dim:
"proj_psi'_l l ∈ carrier_mat N N"
unfolding proj_psi'_l_def using psi'_l_dim by auto
lemma psi_inner_psi'_l:
"inner_prod ψ (psi'_l l) = (alpha_l l * ccos (θ / 2) - beta_l l * csin (θ / 2))"
proof -
have "inner_prod ψ (psi'_l l) = inner_prod ψ (alpha_l l ⋅⇩v α) - inner_prod ψ (beta_l l ⋅⇩v β)"
unfolding psi'_l_def apply (subst inner_prod_minus_distrib_right[of _ N]) by auto
also have "… = alpha_l l * (inner_prod ψ α) - beta_l l * (inner_prod ψ β)"
using ψ_dim α_dim β_dim by auto
also have "… = alpha_l l * (ccos (θ / 2)) - beta_l l * (csin (θ / 2))"
using psi_inner_alpha psi_inner_beta by auto
finally show ?thesis by auto
qed
lemma double_ccos_square:
"2 * ccos (a::real) * ccos a = ccos (2 * a) + 1"
proof -
have eq: "ccos (2 * a) = ccos a * ccos a - csin a * csin a"
using cos_add[of a a] by auto
have "csin a * csin a = 1 - ccos a * ccos a"
using csin_ccos_squared_add[of a]
by (metis add_diff_cancel_left')
then have "ccos a * ccos a - csin a * csin a = 2 * ccos a * ccos a - 1"
by simp
with eq show ?thesis by simp
qed
lemma double_csin_square:
"2 * csin (a::real) * csin a = 1 - ccos (2 * a)"
proof -
have eq: "ccos (2 * a) = ccos a * ccos a - csin a * csin a"
using cos_add[of a a] by auto
have "ccos a * ccos a = 1 - csin a * csin a"
using csin_ccos_squared_add[of a]
by (auto intro: add_implies_diff)
then have "ccos a * ccos a - csin a * csin a = 1 - 2 * csin (a::real) * csin a"
by simp
with eq show ?thesis by simp
qed
lemma csin_double:
"2 * csin (a::real) * ccos a = csin(2 * a)"
using sin_add[of a a] by simp
lemma ccos_add:
"ccos (x + y) = ccos x * ccos y - csin x * csin y"
using cos_add[of x y] by simp
lemma alpha_l_Suc_l_derive:
"2 * (alpha_l l * ccos (θ / 2) - beta_l l * csin (θ / 2)) * ccos (θ / 2) - alpha_l l = alpha_l (l + 1)"
(is "?lhs = ?rhs")
proof -
have "2 * ((alpha_l l) * ccos (θ / 2) - (beta_l l) * csin (θ / 2)) * ccos (θ / 2)
= (alpha_l l) * (2 * ccos (θ / 2)* ccos (θ / 2)) - (beta_l l) * (2 * csin (θ / 2) * ccos (θ / 2))"
by (simp add: left_diff_distrib)
also have "… = (alpha_l l) * (ccos (θ) + 1) - (beta_l l) * csin θ"
using double_ccos_square csin_double by auto
finally have "2 * ((alpha_l l) * ccos (θ / 2) - (beta_l l) * csin (θ / 2)) * ccos (θ / 2)
= (alpha_l l) * (ccos (θ) + 1) - (beta_l l) * csin θ".
then have "?lhs = (alpha_l l) * ccos (θ) - (beta_l l) * csin θ" by (simp add: algebra_simps)
also have "… = (alpha_l (l + 1))"
unfolding alpha_l_def beta_l_def
apply (subst ccos_add[of "(real l + 1 / 2) * θ" "θ", symmetric])
by (simp add: algebra_simps)
finally show ?thesis by auto
qed
lemma csin_add:
"csin (x + y) = ccos x * csin y + csin x * ccos y"
using sin_add[of x y] by simp
lemma beta_l_Suc_l_derive:
"2 * (alpha_l l * ccos (θ / 2) - (beta_l l) * csin (θ / 2)) * csin (θ / 2) + beta_l l = beta_l (l + 1)"
(is "?lhs = ?rhs")
proof -
have "2 * ((alpha_l l) * ccos (θ / 2) - (beta_l l) * csin (θ / 2)) * csin (θ / 2)
= (alpha_l l) * (2 * csin (θ / 2)* ccos (θ / 2)) - (beta_l l) * (2 * csin (θ / 2) * csin (θ / 2))"
by (simp add: left_diff_distrib)
also have "… = (alpha_l l) * (csin θ) - (beta_l l) * (1 - ccos (θ))"
using double_csin_square csin_double by auto
finally have "2 * ((alpha_l l) * ccos (θ / 2) - (beta_l l) * csin (θ / 2)) * csin (θ / 2)
= (alpha_l l) * (csin θ) - (beta_l l) * (1 - ccos (θ))".
then have "?lhs = (alpha_l l) * (csin θ) + (beta_l l) * ccos θ" by (simp add: algebra_simps)
also have "… = (beta_l (l + 1))"
unfolding alpha_l_def beta_l_def
apply (subst csin_add[of "(real l + 1 / 2) * θ" "θ", symmetric])
by (simp add: algebra_simps)
finally show ?thesis by auto
qed
lemma psi_l_Suc_l_derive:
"2 * (alpha_l l * ccos (θ / 2) - beta_l l * csin (θ / 2)) ⋅⇩v ψ - psi'_l l = psi_l (l + 1)"
(is "?lhs = ?rhs")
proof -
let ?l = "2 * ((alpha_l l) * ccos (θ / 2) - (beta_l l) * csin (θ / 2))"
have "?l ⋅⇩v ψ = ?l ⋅⇩v (ccos (θ / 2) ⋅⇩v α + csin (θ / 2) ⋅⇩v β)" unfolding ψ_eq by auto
also have "… = ?l ⋅⇩v (ccos (θ / 2) ⋅⇩v α) + ?l ⋅⇩v (csin (θ / 2) ⋅⇩v β)"
apply (subst smult_add_distrib_vec[of _ N]) using α_dim β_dim by auto
also have "… = (?l * ccos (θ / 2)) ⋅⇩v α + (?l * csin (θ / 2)) ⋅⇩v β" by auto
finally have "?l ⋅⇩v ψ = (?l * ccos (θ / 2)) ⋅⇩v α + (?l * csin (θ / 2)) ⋅⇩v β".
then have "?l ⋅⇩v ψ - (psi'_l l) = ((?l * ccos (θ / 2)) ⋅⇩v α - (alpha_l l) ⋅⇩v α) + ((?l * csin (θ / 2)) ⋅⇩v β + (beta_l l) ⋅⇩v β)"
unfolding psi'_l_def by auto
also have "… = (?l * ccos (θ / 2) - alpha_l l) ⋅⇩v α + (?l * csin (θ / 2) + beta_l l) ⋅⇩v β"
apply (subst minus_smult_vec_distrib) apply (subst add_smult_distrib_vec) by auto
also have "… = (alpha_l (l + 1)) ⋅⇩v α + (beta_l (l + 1)) ⋅⇩v β"
using alpha_l_Suc_l_derive beta_l_Suc_l_derive by auto
finally have "?l ⋅⇩v ψ - (psi'_l l) = (alpha_l (l + 1)) ⋅⇩v α + (beta_l (l + 1)) ⋅⇩v β".
then show ?thesis unfolding psi_l_def by auto
qed
subsection ‹Grover operator›
text ‹Oracle O›
definition proj_O :: "complex mat" where
"proj_O = mat N N (λ(i, j). if i = j then (if f i then 1 else 0) else 0)"
lemma proj_O_dim:
"proj_O ∈ carrier_mat N N"
unfolding proj_O_def by auto
lemma proj_O_mult_alpha:
"proj_O *⇩v α = zero_vec N"
by (auto simp add: proj_O_def α_def scalar_prod_def)
lemma proj_O_mult_beta:
"proj_O *⇩v β = β"
by (auto simp add: proj_O_def β_def scalar_prod_def sum_only_one_neq_0)
definition mat_O :: "complex mat" where
"mat_O = mat N N (λ(i,j). if i = j then (if f i then -1 else 1) else 0)"
lemma mat_O_dim:
"mat_O ∈ carrier_mat N N"
unfolding mat_O_def by auto
lemma mat_O_mult_alpha:
"mat_O *⇩v α = α"
by (auto simp add: mat_O_def α_def scalar_prod_def sum_only_one_neq_0)
lemma mat_O_mult_beta:
"mat_O *⇩v β = - β"
by (auto simp add: mat_O_def β_def scalar_prod_def sum_only_one_neq_0)
lemma hermitian_mat_O:
"hermitian mat_O"
by (auto simp add: hermitian_def mat_O_def adjoint_eval)
lemma unitary_mat_O:
"unitary mat_O"
proof -
have "mat_O ∈ carrier_mat N N" unfolding mat_O_def by auto
moreover have "mat_O * adjoint mat_O = mat_O * mat_O" using hermitian_mat_O unfolding hermitian_def by auto
moreover have "mat_O * mat_O = 1⇩m N"
apply (rule eq_matI)
unfolding mat_O_def
apply (simp add: scalar_prod_def)
subgoal for i j apply (rule)
subgoal apply (subst sum_only_one_neq_0[of "{0..<N}" "j"]) by auto
apply (subst sum_only_one_neq_0[of "{0..<N}" "j"]) by auto
by auto
ultimately show ?thesis unfolding unitary_def inverts_mat_def by auto
qed
definition mat_Ph :: "complex mat" where
"mat_Ph = mat N N (λ(i,j). if i = j then if i = 0 then 1 else -1 else 0)"
lemma hermitian_mat_Ph:
"hermitian mat_Ph"
unfolding hermitian_def mat_Ph_def
apply (rule eq_matI)
by (auto simp add: adjoint_eval)
lemma unitary_mat_Ph:
"unitary mat_Ph"
proof -
have "mat_Ph ∈ carrier_mat N N" unfolding mat_Ph_def by auto
moreover have "mat_Ph * adjoint mat_Ph = mat_Ph * mat_Ph" using hermitian_mat_Ph unfolding hermitian_def by auto
moreover have "mat_Ph * mat_Ph = 1⇩m N"
apply (rule eq_matI)
unfolding mat_Ph_def
apply (simp add: scalar_prod_def)
subgoal for i j apply (rule)
subgoal apply (subst sum_only_one_neq_0[of "{0..<N}" "0"]) by auto
apply (subst sum_only_one_neq_0[of "{0..<N}" "j"]) by auto
by auto
ultimately show ?thesis unfolding unitary_def inverts_mat_def by auto
qed
definition mat_G' :: "complex mat" where
"mat_G' = mat N N (λ(i,j). if i = j then 2 / N - 1 else 2 / N)"
text ‹Geometrically, the Grover operator G is a rotation›
definition mat_G :: "complex mat" where
"mat_G = mat_G' * mat_O"
end
subsection ‹State of Grover's algorithm›
text ‹The dimensions are [2, 2, ..., 2, n]. We work with a very special
case as in the paper›
locale grover_state_sig = grover_state + state_sig +
fixes R :: nat
fixes K :: nat
assumes dims_def: "dims = replicate n 2 @ [K]"
assumes R: "R = pi / (2 * θ) - 1 / 2"
assumes K: "K > R"
begin
lemma K_gt_0:
"K > 0"
using K by auto
text ‹Bits q0 to q\_(n-1)›
definition vars1 :: "nat set" where
"vars1 = {0 ..< n}"
text ‹Bit r›
definition vars2 :: "nat set" where
"vars2 = {n}"
lemma length_dims:
"length dims = n + 1"
unfolding dims_def by auto
lemma dims_nth_lt_n:
"l < n ⟹ nth dims l = 2"
unfolding dims_def by (simp add: nth_append)
lemma nths_Suc_n_dims:
"nths dims {0..<(Suc n)} = dims"
using length_dims nths_upt_eq_take
by (metis add_Suc_right add_Suc_shift lessThan_atLeast0 less_add_eq_less less_numeral_extra(4)
not_less plus_1_eq_Suc take_all)
interpretation ps2_P: partial_state2 dims vars1 vars2
apply unfold_locales unfolding vars1_def vars2_def by auto
interpretation ps_P: partial_state ps2_P.dims0 ps2_P.vars1'.
abbreviation tensor_P where
"tensor_P A B ≡ ps2_P.ptensor_mat A B"
lemma tensor_P_dim:
"tensor_P A B ∈ carrier_mat d d"
proof -
have "ps2_P.d0 = prod_list (nths dims ({0..<n} ∪ {n}))" unfolding ps2_P.d0_def ps2_P.dims0_def ps2_P.vars0_def
by (simp add: vars1_def vars2_def)
also have "… = prod_list (nths dims ({0..<Suc n}))"
apply (subgoal_tac "{0..<n} ∪ {n} = {0..<(Suc n)}") by auto
also have "… = prod_list dims" using nths_Suc_n_dims by auto
also have "… = d" unfolding d_def by auto
finally show ?thesis using ps2_P.ptensor_mat_carrier by auto
qed
lemma dims_nths_le_n:
assumes "l ≤ n"
shows "nths dims {0..<l} = replicate l 2"
proof (rule nth_equalityI, auto)
have "l ≤ n ⟹ (i < Suc n ∧ i < l) = (i < l)" for i
using less_trans by fastforce
then show l: "length (nths dims {0..<l}) = l" using assms
by (auto simp add: length_nths length_dims)
have llt: "l < length dims" using length_dims assms by auto
have v1: "⋀i. i < l ⟹ {a. a < i ∧ a ∈ {0..<l}} = {0..<i}" unfolding vars1_def by auto
then have "⋀i. i < l ⟹ card {j. j < i ∧ j ∈ {0..<l}} = i" by auto
then have "nths dims {0..<l} ! i = dims ! i" if "i < l" for i
using nth_nths_card[of i dims "{0..<l}"] that llt by auto
moreover have "dims ! i = replicate n 2 ! i" if "i < n" for i unfolding dims_def
by (auto simp add: nth_append that)
moreover have "replicate n 2 ! i = replicate l 2 ! i" if "i < l" for i using assms that by auto
ultimately show "nths dims {0..<l} ! i = replicate l 2 ! i" if "i < length (nths dims {0..<l})" for i
using l that assms by auto
qed
lemma dims_nths_one_lt_n:
assumes "l < n"
shows "nths dims {l} = [2]"
proof -
have "{i. i < length dims ∧ i ∈ {l}} = {l}" using assms length_dims by auto
then have "nths dims {l} = [dims ! l]" using nths_only_one[of dims "{l}" l] by auto
moreover have "dims ! l = 2" unfolding dims_def using assms by (simp add: nth_append)
ultimately show ?thesis by auto
qed
lemma dims_vars1:
"nths dims vars1 = replicate n 2"
proof (rule nth_equalityI, auto)
show l: "length (nths dims vars1) = n"
apply (auto simp add: length_nths vars1_def length_dims)
by (metis (no_types, lifting) Collect_cong Suc_lessD card_Collect_less_nat not_less_eq)
have v1: "⋀i. i < n ⟹ {a. a < i ∧ a ∈ vars1} = {0..<i}" unfolding vars1_def by auto
then have "⋀i. i < n ⟹ card {j. j < i ∧ j ∈ vars1} = i" by auto
then have "nths dims vars1 ! i = dims ! i" if "i < n" for i
using nth_nths_card[of i dims vars1] that length_dims vars1_def by auto
moreover have "dims ! i = replicate n 2 ! i" if "i < n" for i unfolding dims_def
by (simp add: nth_append that)
ultimately show "nths dims vars1 ! i = replicate n 2 ! i" if "i < length (nths dims vars1)" for i
using l that by auto
qed
lemma nths_rep_2_n:
"nths (replicate n 2) {n} = []"
by (metis (no_types, lifting) Collect_empty_eq card.empty length_0_conv length_replicate less_Suc_eq not_less_eq nths_replicate singletonD)
lemma dims_vars2:
"nths dims vars2 = [K]"
unfolding dims_def vars2_def
apply (subst nths_append)
apply (subst nths_rep_2_n)
by simp
lemma d_vars1:
"prod_list (nths dims vars1) = N"
proof -
have eq: "{0..<n} = {..<n}" by auto
have "nths (replicate n 2 @ [K]) {0..<n} = (replicate n 2)"
apply (subst eq)
using nths_upt_eq_take by simp
then show ?thesis unfolding dims_def vars1_def N_def by auto
qed
lemma ps2_P_dims0:
"ps2_P.dims0 = dims"
proof -
have "vars1 ∪ vars2 = {0..<Suc n}" unfolding vars1_def vars2_def by auto
then have dims: "nths dims (vars1 ∪ vars2) = dims" unfolding vars1_def vars2_def using nths_Suc_n_dims by auto
then show ?thesis unfolding ps2_P.dims0_def ps2_P.vars0_def apply (subst dims) by auto
qed
lemma ps2_P_vars1':
"ps2_P.vars1' = vars1"
unfolding ps2_P.vars1'_def ps2_P.vars0_def
proof -
have eq: "vars1 ∪ vars2 = {0..<(Suc n)}" unfolding vars1_def vars2_def by auto
have "x < Suc n ⟹ {i ∈ {0..<Suc n}. i < x} = {i. i < x}" for x by auto
then have "x < Suc n ⟹ ind_in_set {0..<(Suc n)} x = x" for x unfolding ind_in_set_def by auto
then have "x ∈ vars1 ⟹ ind_in_set {0..<(Suc n)} x = x" for x unfolding vars1_def by auto
then have "ind_in_set {0..<(Suc n)} ` vars1 = vars1" by force
with eq show "ind_in_set (vars1 ∪ vars2) ` vars1 = vars1" by auto
qed
lemma ps2_P_d0:
"ps2_P.d0 = d"
unfolding ps2_P.d0_def using ps2_P_dims0 d_def by auto
lemma ps2_P_d1:
"ps2_P.d1 = N"
unfolding ps2_P.d1_def ps2_P.dims1_def by (simp add: dims_vars1 N_def)
lemma ps2_P_d2:
"ps2_P.d2 = K"
unfolding ps2_P.d2_def ps2_P.dims2_def by (simp add: dims_vars2)
lemma ps_P_d:
"ps_P.d = d"
unfolding ps_P.d_def ps2_P_dims0 by auto
lemma ps_P_d1:
"ps_P.d1 = N"
unfolding ps_P.d1_def ps_P.dims1_def ps2_P.nths_vars1' using ps2_P_d1 unfolding ps2_P.d1_def by auto
lemma ps_P_d2:
"ps_P.d2 = K"
unfolding ps_P.d2_def ps_P.dims2_def ps2_P.nths_vars2' using ps2_P_d2 unfolding ps2_P.d2_def by auto
lemma nths_uminus_vars1:
"nths dims (- vars1) = nths dims vars2"
using ps2_P.nths_vars2' unfolding ps2_P_dims0 ps2_P_vars1' ps2_P.dims2_def by auto
lemma tensor_P_mult:
assumes "m1 ∈ carrier_mat (2^n) (2^n)"
and "m2 ∈ carrier_mat (2^n) (2^n)"
and "m3 ∈ carrier_mat K K"
and "m4 ∈ carrier_mat K K"
shows "(tensor_P m1 m3) * (tensor_P m2 m4) = tensor_P (m1 * m2) (m3 * m4)"
proof -
have eq:"{0..<n} = {..<n}" by auto
have "(nths dims vars1) = replicate n 2"
unfolding dims_def vars1_def apply (subst eq)
by (simp add: nths_upt_eq_take[of "(replicate n 2 @ [K])" n])
have "ps2_P.d1 = 2^n" unfolding ps2_P.d1_def ps2_P.dims1_def using d_vars1 N_def by auto
moreover have "ps2_P.d2 = K" unfolding ps2_P.d2_def ps2_P.dims2_def using dims_vars2 by auto
ultimately show ?thesis apply (subst ps2_P.ptensor_mat_mult) using assms by auto
qed
lemma mat_ext_vars1:
shows "mat_extension dims vars1 A = tensor_P A (1⇩m K)"
unfolding Utrans_P_def ps2_P.ptensor_mat_def partial_state.mat_extension_def
partial_state.d2_def partial_state.dims2_def ps2_P.nths_vars2'[simplified ps2_P_dims0 ps2_P_vars1']
using ps2_P_d2 unfolding ps2_P.d2_def using ps2_P_dims0 ps2_P_vars1' by auto
lemma Utrans_P_is_tensor_P1:
"Utrans_P vars1 A = Utrans (tensor_P A (1⇩m K))"
unfolding Utrans_P_def ps2_P.ptensor_mat_def partial_state.mat_extension_def
partial_state.d2_def partial_state.dims2_def ps2_P.nths_vars2'[simplified ps2_P_dims0 ps2_P_vars1']
using ps2_P_d2 unfolding ps2_P.d2_def using ps2_P_dims0 ps2_P_vars1' by auto
lemma nths_dims_uminus_vars2:
"nths dims (-vars2) = nths dims vars1"
proof -
have "nths dims (-vars2) = nths dims ({0..<length dims} - vars2)"
using nths_minus_eq by auto
also have "… = nths dims vars1" unfolding vars1_def vars2_def length_dims
apply (subgoal_tac "{0..<n + 1} - {n} = {0..<n}") by auto
finally show ?thesis by auto
qed
lemma mat_ext_vars2:
assumes "A ∈ carrier_mat K K"
shows "mat_extension dims vars2 A = tensor_P (1⇩m N) A"
proof -
have "mat_extension dims vars2 A = tensor_mat dims vars2 A (1⇩m N)"
unfolding Utrans_P_def partial_state.mat_extension_def
partial_state.d2_def partial_state.dims2_def
nths_dims_uminus_vars2 dims_vars1 N_def by auto
also have "… = tensor_mat dims vars1 (1⇩m N) A"
apply (subst tensor_mat_comm[of vars1 vars2])
subgoal unfolding vars1_def vars2_def by auto
subgoal unfolding length_dims vars1_def vars2_def by auto
subgoal unfolding dims_vars1 N_def by auto
unfolding dims_vars2 using assms by auto
finally show "mat_extension dims vars2 A = tensor_P (1⇩m N) A"
unfolding ps2_P.ptensor_mat_def ps2_P_dims0 ps2_P_vars1' by auto
qed
lemma Utrans_P_is_tensor_P2:
assumes "A ∈ carrier_mat K K"
shows "Utrans_P vars2 A = Utrans (tensor_P (1⇩m N) A)"
unfolding Utrans_P_def using mat_ext_vars2 assms by auto
subsection ‹Grover's algorithm›
text ‹Apply hadamard operator to first n variables›
definition hadamard_on_i :: "nat ⇒ complex mat" where
"hadamard_on_i i = pmat_extension dims {i} (vars1 - {i}) hadamard"
declare hadamard_on_i_def [simp]
fun hadamard_n :: "nat ⇒ com" where
"hadamard_n 0 = SKIP"
| "hadamard_n (Suc i) = hadamard_n i ;; Utrans (tensor_P (hadamard_on_i i) (1⇩m K))"
text ‹Body of the loop›
definition D :: com where
"D = Utrans_P vars1 mat_O ;;
hadamard_n n ;;
Utrans_P vars1 mat_Ph ;;
hadamard_n n ;;
Utrans_P vars2 (mat_incr K)"
lemma unitary_ex_mat_O:
"unitary (tensor_P mat_O (1⇩m K))"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_unitary)
subgoal using ps_P_d1 mat_O_def by auto
subgoal using ps_P_d2 by auto
subgoal using unitary_mat_O by auto
using unitary_one by auto
lemma unitary_ex_mat_Ph:
"unitary (tensor_P mat_Ph (1⇩m K))"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_unitary)
subgoal using ps_P_d1 mat_Ph_def by auto
subgoal using ps_P_d2 by auto
subgoal using unitary_mat_Ph by auto
using unitary_one by auto
lemma unitary_hadamard_on_i:
assumes "k < n"
shows "unitary (hadamard_on_i k)"
proof -
interpret st2: partial_state2 dims "{k}" "vars1 - {k}"
apply unfold_locales by auto
show ?thesis unfolding hadamard_on_i_def st2.pmat_extension_def st2.ptensor_mat_def
apply (rule partial_state.tensor_mat_unitary)
subgoal unfolding partial_state.d1_def partial_state.dims1_def st2.nths_vars1' st2.dims1_def
using dims_nths_one_lt_n assms hadamard_dim by auto
subgoal unfolding st2.d2_def st2.dims2_def partial_state.d2_def partial_state.dims2_def st2.nths_vars2' st2.dims1_def
by auto
subgoal using unitary_hadamard by auto
subgoal using unitary_one by auto
done
qed
lemma unitary_exhadamard_on_i:
assumes "k < n"
shows "unitary (tensor_P (hadamard_on_i k) (1⇩m K))"
proof -
interpret st2: partial_state2 dims "{k}" "vars1 - {k}"
apply unfold_locales by auto
have d1: "st2.d0 = partial_state.d1 ps2_P.dims0 ps2_P.vars1'"
unfolding partial_state.d1_def partial_state.dims1_def ps2_P.nths_vars1' ps2_P.dims1_def
st2.d0_def st2.dims0_def st2.vars0_def using assms
apply (subgoal_tac "{k} ∪ (vars1 - {k}) = vars1") apply simp
unfolding vars1_def by auto
show ?thesis
unfolding ps2_P.ptensor_mat_def
apply (rule partial_state.tensor_mat_unitary)
subgoal unfolding hadamard_on_i_def st2.pmat_extension_def
using st2.ptensor_mat_carrier[of hadamard "1⇩m st2.d2"]
using d1 by auto
subgoal unfolding partial_state.d2_def partial_state.dims2_def ps2_P.nths_vars2' ps2_P.dims2_def dims_vars2 by auto
using unitary_hadamard_on_i unitary_one assms by auto
qed
lemma hadamard_on_i_dim:
assumes "k < n"
shows "hadamard_on_i k ∈ carrier_mat N N"
proof -
interpret st: partial_state2 dims "{k}" "(vars1 - {k})"
apply unfold_locales by auto
have vars1: "{k} ∪ (vars1 - {k}) = vars1" unfolding vars1_def using assms by auto
show ?thesis unfolding hadamard_on_i_def N_def using st.pmat_extension_carrier unfolding st.d0_def st.dims0_def st.vars0_def
using vars1 dims_vars1 by auto
qed
lemma well_com_hadamard_k:
"k ≤ n ⟹ well_com (hadamard_n k)"
proof (induct k)
case 0
then show ?case by auto
next
case (Suc n)
then have "well_com (hadamard_n n)" by auto
then show ?case unfolding hadamard_n.simps well_com.simps using tensor_P_dim unitary_exhadamard_on_i Suc by auto
qed
lemma well_com_hadamard_n:
"well_com (hadamard_n n)"
using well_com_hadamard_k by auto
lemma well_com_mat_O:
"well_com (Utrans_P vars1 mat_O)"
apply (subst Utrans_P_is_tensor_P1)
apply simp using tensor_P_dim unitary_ex_mat_O by auto
lemma well_com_mat_Ph:
"well_com (Utrans_P vars1 mat_Ph)"
apply (subst Utrans_P_is_tensor_P1)
apply simp using tensor_P_dim unitary_ex_mat_Ph by auto
lemma unitary_exmat_incr:
"unitary (tensor_P (1⇩m N) (mat_incr K))"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_unitary)
using unitary_mat_incr K unitary_one by (auto simp add: ps_P_d1 ps_P_d2 mat_incr_def)
lemma well_com_mat_incr:
"well_com (Utrans_P vars2 (mat_incr K))"
apply (subst Utrans_P_is_tensor_P2)
apply (simp add: mat_incr_def) using tensor_P_dim unitary_exmat_incr by auto
lemma well_com_D: "well_com D"
unfolding D_def apply auto
using well_com_hadamard_n well_com_mat_incr well_com_mat_O well_com_mat_Ph
by auto
text ‹Test at while loop›
definition M0 :: "complex mat" where
"M0 = mat K K (λ(i,j). if i = j ∧ i ≥ R then 1 else 0)"
lemma hermitian_M0:
"hermitian M0"
by (auto simp add: hermitian_def M0_def adjoint_eval)
lemma M0_dim:
"M0 ∈ carrier_mat K K"
unfolding M0_def by auto
lemma M0_mult_M0:
"M0 * M0 = M0"
by (auto simp add: M0_def scalar_prod_def sum_only_one_neq_0)
definition M1 :: "complex mat" where
"M1 = mat K K (λ(i,j). if i = j ∧ i < R then 1 else 0)"
lemma M1_dim:
"M1 ∈ carrier_mat K K"
unfolding M1_def by auto
lemma hermitian_M1:
"hermitian M1"
by (auto simp add: hermitian_def M1_def adjoint_eval)
lemma M1_mult_M1:
"M1 * M1 = M1"
by (auto simp add: M1_def scalar_prod_def sum_only_one_neq_0)
lemma M1_add_M0:
"M1 + M0 = 1⇩m K"
unfolding M0_def M1_def by auto
text ‹Test at the end›
definition testN :: "nat ⇒ complex mat" where
"testN k = mat N N (λ(i,j). if i = k ∧ j = k then 1 else 0)"
lemma hermitian_testN:
"hermitian (testN k)"
unfolding hermitian_def testN_def
by (auto simp add: scalar_prod_def adjoint_eval)
lemma testN_mult_testN:
"testN k * testN k = testN k"
unfolding testN_def
by (auto simp add: scalar_prod_def sum_only_one_neq_0)
lemma testN_dim:
"testN k ∈ carrier_mat N N"
unfolding testN_def by auto
definition test_fst_k :: "nat ⇒ complex mat" where
"test_fst_k k = mat N N (λ(i, j). if (i = j ∧ i < k) then 1 else 0)"
lemma sum_test_k:
assumes "m ≤ N"
shows "matrix_sum N (λk. testN k) m = test_fst_k m"
proof -
have "m ≤ N ⟹ matrix_sum N (λk. testN k) m = mat N N (λ(i, j). if (i = j ∧ i < m) then 1 else 0)" for m
proof (induct m)
case 0
then show ?case apply simp apply (rule eq_matI) by auto
next
case (Suc m)
then have m: "m < N" by auto
then have m': "m ≤ N" by auto
have "matrix_sum N testN (Suc m) = testN m + matrix_sum N testN m" by simp
also have "… = mat N N (λ(i, j). if (i = j ∧ i < (Suc m)) then 1 else 0)"
unfolding testN_def Suc(1)[OF m'] apply (rule eq_matI) by auto
finally show ?case by auto
qed
then show ?thesis unfolding test_fst_k_def using assms by auto
qed
lemma test_fst_kN:
"test_fst_k N = 1⇩m N"
apply (rule eq_matI)
unfolding test_fst_k_def by auto
lemma matrix_sum_tensor_P1:
"(⋀k. k < m ⟹ g k ∈ carrier_mat N N) ⟹ (A ∈ carrier_mat K K) ⟹
matrix_sum d (λk. tensor_P (g k) A) m = tensor_P (matrix_sum N g m) A"
proof (induct m)
case 0
show ?case apply (simp) unfolding ps2_P.ptensor_mat_def
using ps_P.tensor_mat_zero1[simplified ps_P_d ps_P_d1, of A] by auto
next
case (Suc m)
then have ind: "matrix_sum d (λk. tensor_P (g k) A) m = tensor_P (matrix_sum N g m) A"
and dk: "⋀k. k < m ⟹ g k ∈ carrier_mat N N" and "A ∈ carrier_mat K K" by auto
have ds: "matrix_sum N g m ∈ carrier_mat N N" apply (subst matrix_sum_dim)
using dk by auto
show ?case apply simp
apply (subst ind)
unfolding ps2_P.ptensor_mat_def apply (subst ps_P.tensor_mat_add1)
unfolding ps_P_d1 ps_P_d2 using Suc ds by auto
qed
text ‹Grover's algorithm. Assume we start in the zero state›
definition Grover :: com where
"Grover = hadamard_n n ;;
While_P vars2 M0 M1 D ;;
Measure_P vars1 N testN (replicate N SKIP)"
lemma well_com_if:
"well_com (Measure_P vars1 N testN (replicate N SKIP))"
unfolding Measure_P_def apply auto
proof -
have eq0: "⋀n. mat_extension dims vars1 (testN n) = tensor_P (testN n) (1⇩m K)"
unfolding mat_ext_vars1 by auto
have eq1: "adjoint (tensor_P (testN j) (1⇩m K)) * tensor_P (testN j) (1⇩m K) = tensor_P (testN j) (1⇩m K)" for j
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_adjoint)
apply (auto simp add: ps_P_d1 ps_P_d2 testN_dim hermitian_testN[unfolded hermitian_def] hermitian_one[unfolded hermitian_def])
apply (subst ps_P.tensor_mat_mult[symmetric])
by (auto simp add: ps_P_d1 ps_P_d2 testN_dim testN_mult_testN)
have "measurement d N (λn. tensor_P (testN n) (1⇩m K))"
unfolding measurement_def
apply (simp add: tensor_P_dim)
apply (subst eq1)
apply (subst matrix_sum_tensor_P1)
apply (auto simp add: testN_dim)
apply (subst sum_test_k, simp)
apply (subst test_fst_kN)
unfolding ps2_P.ptensor_mat_def
using ps_P.tensor_mat_id ps_P_d ps_P_d1 ps_P_d2 by auto
then show "measurement d N (λn. mat_extension dims vars1 (testN n))" using eq0 by auto
show "list_all well_com (replicate N SKIP)"
apply (subst list_all_length) by simp
qed
lemma well_com_while:
"well_com (While_P vars2 M0 M1 D)"
unfolding While_P_def apply auto
apply (subst (1 2) mat_ext_vars2)
apply (auto simp add: M1_dim M0_dim)
proof -
have 2: "2 = Suc (Suc 0)" by auto
have ad0: "adjoint (tensor_P (1⇩m N) M0) = (tensor_P (1⇩m N) M0)"
unfolding ps2_P.ptensor_mat_def apply (subst ps_P.tensor_mat_adjoint)
unfolding ps_P_d1 ps_P_d2 by (auto simp add: M0_dim adjoint_one hermitian_M0[unfolded hermitian_def])
have ad1: "adjoint (tensor_P (1⇩m N) M1) = (tensor_P (1⇩m N) M1)"
unfolding ps2_P.ptensor_mat_def apply (subst ps_P.tensor_mat_adjoint)
unfolding ps_P_d1 ps_P_d2 by (auto simp add: M1_dim adjoint_one hermitian_M1[unfolded hermitian_def])
have m0: "tensor_P (1⇩m N) M0 * tensor_P (1⇩m N) M0 = tensor_P (1⇩m N) M0"
unfolding ps2_P.ptensor_mat_def apply (subst ps_P.tensor_mat_mult[symmetric])
unfolding ps_P_d1 ps_P_d2 using M0_dim M0_mult_M0 by auto
have m1: "tensor_P (1⇩m N) M1 * tensor_P (1⇩m N) M1 = tensor_P (1⇩m N) M1"
unfolding ps2_P.ptensor_mat_def apply (subst ps_P.tensor_mat_mult[symmetric])
unfolding ps_P_d1 ps_P_d2 using M1_dim M1_mult_M1 by auto
have s: "tensor_P (1⇩m N) M1 + tensor_P (1⇩m N) M0 = 1⇩m d"
unfolding ps2_P.ptensor_mat_def apply (subst ps_P.tensor_mat_add2[symmetric])
unfolding ps_P_d1 ps_P_d2
by (auto simp add: M1_dim M0_dim M1_add_M0 ps_P.tensor_mat_id[simplified ps_P_d1 ps_P_d2 ps_P_d])
show "measurement d 2 (λn. if n = 0 then tensor_P (1⇩m N) M0 else if n = 1 then tensor_P (1⇩m N) M1 else undefined)"
unfolding measurement_def apply (auto simp add: tensor_P_dim) apply (subst 2)
apply (simp add: ad0 ad1 m0 m1)
apply (subst assoc_add_mat[symmetric, of _ d d]) using tensor_P_dim s by auto
show "well_com D" using well_com_D by auto
qed
lemma well_com_Grover:
"well_com Grover"
unfolding Grover_def apply auto
using well_com_hadamard_n well_com_if well_com_while by auto
subsection ‹Correctness›
text ‹Pre-condition: assume in the zero state›
definition ket_pre :: "complex vec" where
"ket_pre = Matrix.vec N (λk. if k = 0 then 1 else 0)"
lemma ket_pre_dim:
"ket_pre ∈ carrier_vec N" using ket_pre_def by auto
definition pre :: "complex mat" where
"pre = proj ket_pre"
lemma pre_dim:
"pre ∈ carrier_mat N N"
using pre_def ket_pre_def by auto
lemma norm_pre:
"inner_prod ket_pre ket_pre = 1"
unfolding ket_pre_def scalar_prod_def
using sum_only_one_neq_0[of "{0..<N}" 0 "λi. (if i = 0 then 1 else 0) * cnj (if i = 0 then 1 else 0)"] by auto
lemma pre_trace:
"trace pre = 1"
unfolding pre_def
apply (subst trace_outer_prod[of _ N])
subgoal unfolding ket_pre_def by auto using norm_pre by auto
lemma positive_pre:
"positive pre"
using positive_same_outer_prod unfolding pre_def ket_pre_def by auto
lemma pre_le_one:
"pre ≤⇩L 1⇩m N"
unfolding pre_def using outer_prod_le_one norm_pre ket_pre_def by auto
text ‹Post-condition: should be in a state i with f i = 1›
definition post :: "complex mat" where
"post = mat N N (λ(i, j). if (i = j ∧ f i) then 1 else 0)"
lemma post_dim:
"post ∈ carrier_mat N N"
unfolding post_def by auto
lemma hermitian_post:
"hermitian post"
unfolding hermitian_def post_def
by (auto simp add: adjoint_eval)
text ‹Hoare triples of initialization›
definition ket_zero :: "complex vec" where
"ket_zero = Matrix.vec 2 (λk. if k = 0 then 1 else 0)"
lemma ket_zero_dim:
"ket_zero ∈ carrier_vec 2" unfolding ket_zero_def by auto
definition proj_zero where
"proj_zero = proj ket_zero"
definition ket_one where
"ket_one = Matrix.vec 2 (λk. if k = 1 then 1 else 0)"
definition proj_one where
"proj_one = proj ket_one"
definition ket_plus where
"ket_plus = Matrix.vec 2 (λk.1 / csqrt 2) "
lemma ket_plus_dim:
"ket_plus ∈ carrier_vec 2" unfolding ket_plus_def by auto
lemma ket_plus_eval [simp]:
"i < 2 ⟹ ket_plus $ i = 1 / csqrt 2"
apply (simp only: ket_plus_def)
using index_vec less_2_cases by force
lemma csqrt_2_sq [simp]:
"complex_of_real (sqrt 2) * complex_of_real (sqrt 2) = 2"
by (smt of_real_add of_real_hom.hom_one of_real_power one_add_one power2_eq_square real_sqrt_pow2)
lemma ket_plus_tensor_n:
"partial_state.tensor_vec [2, 2] {0} ket_plus ket_plus = Matrix.vec 4 (λk. 1 / 2)"
unfolding partial_state.tensor_vec_def state_sig.d_def
proof (rule eq_vecI, auto)
fix i :: nat assume i: "i < 4"
interpret st: partial_state "[2, 2]" "{0}" .
have d1_eq: "st.d1 = 2"
by (simp add: st.d1_def st.dims1_def nths_def)
have "st.encode1 i < st.d1"
by (simp add: st.d_def i)
then have i1_lt: "st.encode1 i < 2"
using d1_eq by auto
have d2_eq: "st.d2 = 2"
by (simp add: st.d2_def st.dims2_def nths_def)
have "st.encode2 i < st.d2"
by (simp add: st.d_def i)
then have i2_lt: "st.encode2 i < 2"
using d2_eq by auto
show "ket_plus $ st.encode1 i * ket_plus $ st.encode2 i * 2 = 1"
by (auto simp add: i1_lt i2_lt)
qed
definition proj_plus where
"proj_plus = proj ket_plus"
lemma hadamard_on_zero:
"hadamard *⇩v ket_zero = ket_plus"
unfolding hadamard_def ket_zero_def ket_plus_def mat_of_rows_list_def
apply (rule eq_vecI, auto simp add: scalar_prod_def)
subgoal for i
apply (drule less_2_cases)
apply (drule disjE, auto)
by (subst sum_le_2, auto)+.
fun exH_k :: "nat ⇒ complex mat" where
"exH_k 0 = hadamard_on_i 0"
| "exH_k (Suc k) = exH_k k * hadamard_on_i (Suc k)"
fun H_k :: "nat ⇒ complex mat" where
"H_k 0 = hadamard"
| "H_k (Suc k) = ptensor_mat dims {0..<Suc k} {Suc k} (H_k k) hadamard"
lemma H_k_dim:
"k < n ⟹ H_k k ∈ carrier_mat (2^(Suc k)) (2^(Suc k))"
proof (induct k)
case 0
then show ?case using hadamard_dim by auto
next
case (Suc k)
interpret st: partial_state2 dims "{0..<(Suc k)}" "{Suc k}"
apply unfold_locales by auto
have "Suc (Suc k) ≤ n" using Suc by auto
then have "nths dims ({0..<Suc (Suc k)}) = replicate (Suc (Suc k)) 2" using dims_nths_le_n by auto
moreover have "prod_list (replicate l 2) = 2^l" for l by simp
moreover have "{0..<Suc k} ∪ {Suc k} = {0..<(Suc (Suc k))}" by auto
ultimately have plssk: "prod_list (nths dims ({0..<Suc k} ∪ {Suc k})) = 2^(Suc (Suc k))" by auto
have "dim_col (H_k (Suc k)) = 2^(Suc (Suc k))" using st.ptensor_mat_dim_col unfolding st.d0_def st.dims0_def st.vars0_def using plssk by auto
moreover have "dim_row (H_k (Suc k)) = 2^(Suc (Suc k))" using st.ptensor_mat_dim_row unfolding st.d0_def st.dims0_def st.vars0_def using plssk by auto
ultimately show ?case by auto
qed
lemma exH_k_eq_H_k:
"k < n ⟹ exH_k k = pmat_extension dims {0..<(Suc k)} {(Suc k)..<n} (H_k k)"
proof(induct k)
case 0
have "{(Suc 0)..<n} = vars1 - {0..<(Suc 0)}" using vars1_def by fastforce
then show ?case unfolding exH_k.simps using vars1_def by auto
next
case (Suc k)
interpret st: partial_state2 dims "{0..<Suc k}" "{(Suc k)..<n}"
apply unfold_locales by auto
interpret st1: partial_state2 dims "{Suc k}" "{(Suc (Suc k))..<n}"
apply unfold_locales by auto
interpret st2: partial_state2 dims "{Suc k}" "vars1 - {Suc k}"
apply unfold_locales by auto
interpret st3: partial_state2 dims "{0..<Suc k}" "{Suc (Suc k)..<n}"
apply unfold_locales by auto
interpret st4: partial_state2 dims "{0..<Suc (Suc k)}" "{Suc (Suc k)..<n}"
apply unfold_locales by auto
from Suc have eq0: "exH_k (Suc k)
= (st.pmat_extension (H_k k)) * (st2.pmat_extension hadamard)" by auto
have "vars1 - {0..<Suc k} = {(Suc k)..<n}" using vars1_def by auto
then have eql1: "st.pmat_extension (H_k k) = st.ptensor_mat (H_k k) (1⇩m st.d2)"
using st.pmat_extension_def by auto
from dims_nths_one_lt_n[OF Suc(2)] have st1d1: "st1.d1 = 2" unfolding st1.d1_def st1.dims1_def by fastforce
have "{Suc k} ∪ {Suc (Suc k)..<n} = {Suc k..<n}" using Suc by auto
then have "st1.d0 = st.d2" unfolding st1.d0_def st1.dims0_def st1.vars0_def st.d2_def st.dims2_def by fastforce
then have eql2: "st1.ptensor_mat (1⇩m 2) (1⇩m st1.d2) = 1⇩m st.d2"
using st1.ptensor_mat_id st1d1 by auto
have eql3: "st.ptensor_mat (H_k k) (1⇩m st.d2) = st.ptensor_mat (H_k k) (st1.ptensor_mat (1⇩m 2) (1⇩m st1.d2))"
apply (subst eql2[symmetric]) by auto
have eqr1: "(st2.pmat_extension hadamard) = st2.ptensor_mat hadamard (1⇩m st2.d2)" using st2.pmat_extension_def by auto
have splitset: "{0..<Suc k} ∪ {Suc (Suc k)..<n} = vars1 - {Suc k}" unfolding vars1_def using Suc(2) by auto
have Sksplit: "{Suc k} ∪ {Suc (Suc k)..<n} = {Suc k..<n}" using Suc(2) by auto
have Sksplit1: "{0..<Suc k}∪{Suc k} = {0..<Suc (Suc k)}" by auto
have "st.ptensor_mat (H_k k) (st1.ptensor_mat (1⇩m 2) (1⇩m st1.d2))
= ptensor_mat dims ({0..<Suc k}∪{Suc k}) {Suc (Suc k)..<n} (ptensor_mat dims {0..<Suc k} {Suc k} (H_k k) (1⇩m 2)) (1⇩m st1.d2)"
apply (subst ptensor_mat_assoc[symmetric, of "{0..<Suc k}" "{Suc k}" "{Suc (Suc k)..<n}" "H_k k" "1⇩m 2" "1⇩m st1.d2", simplified Sksplit])
using Suc length_dims by auto
also have "… = ptensor_mat dims ({0..<Suc k}∪{Suc k}) {Suc (Suc k)..<n} (ptensor_mat dims {Suc k} {0..<Suc k} (1⇩m 2) (H_k k)) (1⇩m st1.d2)"
using ptensor_mat_comm[of "{0..<Suc k}" "{Suc k}"] by auto
also have "… = ptensor_mat dims {Suc k} ({0..<Suc k} ∪ {Suc (Suc k)..<n})
(1⇩m 2)
(ptensor_mat dims {0..<Suc k} {Suc (Suc k)..<n} (H_k k) (1⇩m st1.d2))"
apply (subst sup_commute)
apply (subst ptensor_mat_assoc[of "{Suc k}" "{0..<Suc k}" "{Suc (Suc k)..<n}" "(1⇩m 2)" "H_k k" "1⇩m st1.d2"])
using Suc length_dims by auto
finally have eql4: "st.pmat_extension (H_k k)
= st2.ptensor_mat (1⇩m 2) (st3.ptensor_mat (H_k k) (1⇩m st3.d2))" using eql1 eql3 splitset by auto
have "st2.ptensor_mat (1⇩m 2) (st3.ptensor_mat (H_k k) (1⇩m st3.d2)) * st2.ptensor_mat hadamard (1⇩m st2.d2)
= st2.ptensor_mat ((1⇩m 2)*hadamard) ((st3.ptensor_mat (H_k k) (1⇩m st3.d2))*(1⇩m st2.d2))"
apply (rule st2.ptensor_mat_mult[symmetric, of "1⇩m 2" "hadamard" "(st3.ptensor_mat (H_k k) (1⇩m st3.d2))" "(1⇩m st2.d2)"])
subgoal unfolding st2.d1_def st2.dims1_def
by (simp add: dims_nths_one_lt_n Suc(2))
subgoal unfolding st2.d1_def st2.dims1_def
apply (simp add: dims_nths_one_lt_n Suc(2)) using hadamard_dim by auto
subgoal unfolding st2.d2_def[unfolded st2.dims2_def]
using st3.ptensor_mat_dim_col[unfolded st3.d0_def st3.dims0_def st3.vars0_def, simplified splitset]
st3.ptensor_mat_dim_row[unfolded st3.d0_def st3.dims0_def st3.vars0_def, simplified splitset] by auto
by auto
also have "… = st2.ptensor_mat (hadamard) (st3.ptensor_mat (H_k k) (1⇩m st3.d2))"
unfolding st2.d2_def[unfolded st2.dims2_def]
using hadamard_dim st3.ptensor_mat_dim_col[unfolded st3.d0_def st3.dims0_def st3.vars0_def, simplified splitset]
st3.ptensor_mat_dim_row[unfolded st3.d0_def st3.dims0_def st3.vars0_def, simplified splitset] by auto
also have "… = ptensor_mat dims ({0..<Suc k}∪{Suc k}) {Suc (Suc k)..<n} (ptensor_mat dims {Suc k} {0..<Suc k} hadamard (H_k k)) (1⇩m st3.d2)"
apply (subst ptensor_mat_assoc[symmetric, of "{Suc k}" "{0..<Suc k}" "{Suc (Suc k)..<n}" "hadamard" "H_k k" "1⇩m st3.d2", simplified splitset])
using Suc length_dims by auto
also have "… = ptensor_mat dims ({0..<Suc k}∪{Suc k}) {Suc (Suc k)..<n} (H_k (Suc k)) (1⇩m st3.d2)"
using ptensor_mat_comm[of "{Suc k}"] Sksplit1 by auto
also have "… = ptensor_mat dims ({0..<Suc (Suc k)}) {Suc (Suc k)..<n} (H_k (Suc k)) (1⇩m st3.d2)" using Sksplit1 by auto
also have "… = pmat_extension dims {0..<Suc (Suc k)} {Suc (Suc k)..<n} (H_k (Suc k))"
unfolding st4.pmat_extension_def by auto
finally show ?case using eq0 eql4 eqr1 by auto
qed
lemma mult_exH_k_left:
assumes "Suc k < n"
shows "hadamard_on_i (Suc k) * exH_k k = exH_k (Suc k)"
proof -
interpret st: partial_state2 dims "{0..<Suc k}" "{(Suc k)..<n}"
apply unfold_locales by auto
interpret st1: partial_state2 dims "{Suc k}" "{(Suc (Suc k))..<n}"
apply unfold_locales by auto
interpret st2: partial_state2 dims "{Suc k}" "vars1 - {Suc k}"
apply unfold_locales by auto
interpret st3: partial_state2 dims "{0..<Suc k}" "{Suc (Suc k)..<n}"
apply unfold_locales by auto
interpret st4: partial_state2 dims "{0..<Suc (Suc k)}" "{Suc (Suc k)..<n}"
apply unfold_locales by auto
from exH_k_eq_H_k assms have eq0: "exH_k (Suc k)
= (st.pmat_extension (H_k k)) * (st2.pmat_extension hadamard)" by auto
have "vars1 - {0..<Suc k} = {(Suc k)..<n}" using vars1_def by auto
then have eql1: "st.pmat_extension (H_k k) = st.ptensor_mat (H_k k) (1⇩m st.d2)"
using st.pmat_extension_def by auto
from dims_nths_one_lt_n[OF assms] have st1d1: "st1.d1 = 2" unfolding st1.d1_def st1.dims1_def by fastforce
have "{Suc k} ∪ {Suc (Suc k)..<n} = {Suc k..<n}" using assms by auto
then have "st1.d0 = st.d2" unfolding st1.d0_def st1.dims0_def st1.vars0_def st.d2_def st.dims2_def by fastforce
then have eql2: "st1.ptensor_mat (1⇩m 2) (1⇩m st1.d2) = 1⇩m st.d2"
using st1.ptensor_mat_id st1d1 by auto
have eql3: "st.ptensor_mat (H_k k) (1⇩m st.d2) = st.ptensor_mat (H_k k) (st1.ptensor_mat (1⇩m 2) (1⇩m st1.d2))"
apply (subst eql2[symmetric]) by auto
have eqr1: "(st2.pmat_extension hadamard) = st2.ptensor_mat hadamard (1⇩m st2.d2)" using st2.pmat_extension_def by auto
have splitset: "{0..<Suc k} ∪ {Suc (Suc k)..<n} = vars1 - {Suc k}" unfolding vars1_def using assms by auto
have Sksplit: "{Suc k} ∪ {Suc (Suc k)..<n} = {Suc k..<n}" using assms by auto
have Sksplit1: "{0..<Suc k}∪{Suc k} = {0..<Suc (Suc k)}" by auto
have "st.ptensor_mat (H_k k) (st1.ptensor_mat (1⇩m 2) (1⇩m st1.d2))
= ptensor_mat dims ({0..<Suc k}∪{Suc k}) {Suc (Suc k)..<n} (ptensor_mat dims {0..<Suc k} {Suc k} (H_k k) (1⇩m 2)) (1⇩m st1.d2)"
apply (subst ptensor_mat_assoc[symmetric, of "{0..<Suc k}" "{Suc k}" "{Suc (Suc k)..<n}" "H_k k" "1⇩m 2" "1⇩m st1.d2", simplified Sksplit])
using assms length_dims by auto
also have "… = ptensor_mat dims ({0..<Suc k}∪{Suc k}) {Suc (Suc k)..<n} (ptensor_mat dims {Suc k} {0..<Suc k} (1⇩m 2) (H_k k)) (1⇩m st1.d2)"
using ptensor_mat_comm[of "{0..<Suc k}" "{Suc k}"] by auto
also have "… = ptensor_mat dims {Suc k} ({0..<Suc k} ∪ {Suc (Suc k)..<n})
(1⇩m 2)
(ptensor_mat dims {0..<Suc k} {Suc (Suc k)..<n} (H_k k) (1⇩m st1.d2))"
apply (subst sup_commute)
apply (subst ptensor_mat_assoc[of "{Suc k}" "{0..<Suc k}" "{Suc (Suc k)..<n}" "(1⇩m 2)" "H_k k" "1⇩m st1.d2"]) using assms length_dims by auto
finally have "st.pmat_extension (H_k k)
= st2.ptensor_mat (1⇩m 2) (st3.ptensor_mat (H_k k) (1⇩m st3.d2))" using eql1 eql3 splitset by auto
moreover have "st.pmat_extension (H_k k) = exH_k k" using exH_k_eq_H_k assms by auto
ultimately have eql4: "exH_k k = st2.ptensor_mat (1⇩m 2) (st3.ptensor_mat (H_k k) (1⇩m st3.d2))" by auto
have "st2.ptensor_mat hadamard (1⇩m st2.d2) * st2.ptensor_mat (1⇩m 2) (st3.ptensor_mat (H_k k) (1⇩m st3.d2))
= st2.ptensor_mat (hadamard*(1⇩m 2)) ((1⇩m st2.d2)* (st3.ptensor_mat (H_k k) (1⇩m st3.d2)))"
apply (rule st2.ptensor_mat_mult[symmetric, of "hadamard" "1⇩m 2" "(1⇩m st2.d2)" "(st3.ptensor_mat (H_k k) (1⇩m st3.d2))"])
subgoal unfolding st2.d1_def st2.dims1_def apply (simp add: dims_nths_one_lt_n assms) using hadamard_dim by auto
subgoal unfolding st2.d1_def st2.dims1_def by (simp add: dims_nths_one_lt_n assms)
subgoal by auto
subgoal unfolding st2.d2_def[unfolded st2.dims2_def] using st3.ptensor_mat_dim_col[unfolded st3.d0_def st3.dims0_def st3.vars0_def, simplified splitset]
st3.ptensor_mat_dim_row[unfolded st3.d0_def st3.dims0_def st3.vars0_def, simplified splitset] by auto
done
also have "… = st2.ptensor_mat (hadamard) (st3.ptensor_mat (H_k k) (1⇩m st3.d2))"
unfolding st2.d2_def[unfolded st2.dims2_def]
using hadamard_dim st3.ptensor_mat_dim_col[unfolded st3.d0_def st3.dims0_def st3.vars0_def, simplified splitset]
st3.ptensor_mat_dim_row[unfolded st3.d0_def st3.dims0_def st3.vars0_def, simplified splitset] by auto
also have "… = ptensor_mat dims ({0..<Suc k}∪{Suc k}) {Suc (Suc k)..<n} (ptensor_mat dims {Suc k} {0..<Suc k} hadamard (H_k k)) (1⇩m st3.d2)"
apply (subst ptensor_mat_assoc[symmetric, of "{Suc k}" "{0..<Suc k}" "{Suc (Suc k)..<n}" "hadamard" "H_k k" "1⇩m st3.d2", simplified splitset])
using assms length_dims by auto
also have "… = ptensor_mat dims ({0..<Suc k}∪{Suc k}) {Suc (Suc k)..<n} (H_k (Suc k)) (1⇩m st3.d2)"
using ptensor_mat_comm[of "{Suc k}"] Sksplit1 by auto
also have "… = ptensor_mat dims ({0..<Suc (Suc k)}) {Suc (Suc k)..<n} (H_k (Suc k)) (1⇩m st3.d2)" using Sksplit1 by auto
also have "… = pmat_extension dims {0..<Suc (Suc k)} {Suc (Suc k)..<n} (H_k (Suc k))"
unfolding st4.pmat_extension_def by auto
also have "… = exH_k (Suc k)" using exH_k_eq_H_k[of "Suc k"] assms by auto
finally have "st2.ptensor_mat hadamard (1⇩m st2.d2) * st2.ptensor_mat (1⇩m 2) (st3.ptensor_mat (H_k k) (1⇩m st3.d2))
=exH_k (Suc k)".
then show ?thesis unfolding hadamard_on_i_def
using eql4 eqr1 by auto
qed
lemma exH_eq_H:
"exH_k (n - 1) = H_k (n - 1)"
proof -
have "∃m. n = Suc (Suc m)" using n by presburger
then obtain m where m: "n = Suc (Suc m)" using n by auto
then have "exH_k m = pmat_extension dims {0..<(Suc m)} {(Suc m)..<n} (H_k m)" using exH_k_eq_H_k by auto
then have "exH_k (Suc m) = pmat_extension dims {0..<(Suc m)} {(Suc m)..<n} (H_k m)
* (pmat_extension dims {Suc m} (vars1 - {Suc m}) hadamard)" by auto
moreover have "{(Suc m)..<n} = {Suc m}" using m by auto
moreover have "vars1 - {Suc m} = {0..<Suc m}" unfolding vars1_def using m by auto
ultimately have eqSm: "exH_k (Suc m) = pmat_extension dims {0..<(Suc m)} {Suc m} (H_k m)
* (pmat_extension dims {Suc m} {0..<Suc m} hadamard)" by auto
interpret stm1: partial_state2 dims "{Suc m}" "{0..<Suc m}"
apply unfold_locales by auto
interpret stm2: partial_state2 dims "{0..<Suc m}" "{Suc m}"
apply unfold_locales by auto
have "nths dims {0..<Suc m} = replicate (Suc m) 2" using dims_nths_le_n m by auto
then have stm2d1: "stm2.d1 = 2^(Suc m)" unfolding stm2.d1_def stm2.dims1_def by auto
have stm2d2: "stm2.d2 = 2" unfolding stm2.d2_def stm2.dims2_def using dims_nths_one_lt_n m by auto
have "m < n" using m by auto
then have "H_k m ∈ carrier_mat (2^(Suc m)) (2^(Suc m))" using H_k_dim by auto
then have Hkm1: "(H_k m) * (1⇩m stm2.d1) = (H_k m)" unfolding stm2d1 by auto
have eqd12: "stm1.d2 = stm2.d1" unfolding stm1.d2_def stm1.dims2_def stm2.d1_def stm2.dims1_def by auto
have "pmat_extension dims {Suc m} {0..<Suc m} hadamard = stm1.ptensor_mat hadamard (1⇩m stm1.d2)" using stm1.pmat_extension_def by auto
also have "… = stm2.ptensor_mat (1⇩m stm2.d1) hadamard" using ptensor_mat_comm eqd12 by auto
finally have eqr: "(pmat_extension dims {Suc m} {0..<Suc m} hadamard) = stm2.ptensor_mat (1⇩m stm2.d1) hadamard".
then have "exH_k (Suc m) = stm2.ptensor_mat (H_k m) (1⇩m stm2.d2) * stm2.ptensor_mat (1⇩m stm2.d1) hadamard"
using eqSm unfolding stm2.pmat_extension_def by auto
also have "… = stm2.ptensor_mat ((H_k m) * (1⇩m stm2.d1)) (1⇩m stm2.d2 * hadamard)"
apply (rule stm2.ptensor_mat_mult[symmetric, of "H_k m" "1⇩m stm2.d1" "1⇩m stm2.d2" "hadamard"])
unfolding stm2d1 stm2d2 using H_k_dim m hadamard_dim by auto
also have "… = stm2.ptensor_mat (H_k m) (hadamard)" using H_k_dim hadamard_dim stm2d1 stm2d2 Hkm1 by auto
also have "… = H_k (Suc m)" unfolding stm2.ptensor_mat_def H_k.simps by auto
finally have "exH_k (Suc m) = H_k (Suc m)" by auto
moreover have "Suc m = n - 1" using m by auto
ultimately show ?thesis by auto
qed
fun ket_zero_k :: "nat ⇒ complex vec" where
"ket_zero_k 0 = ket_zero"
| "ket_zero_k (Suc k) = ptensor_vec dims {0..<(Suc k)} {Suc k} (ket_zero_k k) ket_zero"
lemma ket_zero_k_dim:
assumes "k < n"
shows "ket_zero_k k ∈ carrier_vec (2^(Suc k))"
proof (cases k)
case 0
show ?thesis using ket_zero_dim 0 by auto
next
case (Suc k)
interpret st: partial_state2 dims "{0..<(Suc k)}" "{Suc k}"
apply unfold_locales by auto
have "Suc (Suc k) ≤ n" using assms Suc by auto
then have "nths dims ({0..<Suc (Suc k)}) = replicate (Suc (Suc k)) 2" using dims_nths_le_n by auto
moreover have "prod_list (replicate l 2) = 2^l" for l by simp
moreover have "{0..<Suc k} ∪ {Suc k} = {0..<(Suc (Suc k))}" by auto
ultimately have plssk: "prod_list (nths dims ({0..<Suc k} ∪ {Suc k})) = 2^(Suc (Suc k))" by auto
show ?thesis apply (rule carrier_vecI) unfolding ket_zero_k.simps Suc
using st.ptensor_vec_dim[of "ket_zero_k k" ket_zero] plssk unfolding st.d0_def st.dims0_def st.vars0_def by auto
qed
fun ket_plus_k where
"ket_plus_k 0 = ket_plus"
| "ket_plus_k (Suc k) = ptensor_vec dims {0..<(Suc k)} {Suc k} (ket_plus_k k) ket_plus"
lemma ket_plus_k_dim:
assumes "k < n"
shows "ket_plus_k k ∈ carrier_vec (2^(Suc k))"
proof (cases k)
case 0
show ?thesis using ket_plus_dim 0 by auto
next
case (Suc k)
interpret st: partial_state2 dims "{0..<(Suc k)}" "{Suc k}"
apply unfold_locales by auto
have "Suc (Suc k) ≤ n" using assms Suc by auto
then have "nths dims ({0..<Suc (Suc k)}) = replicate (Suc (Suc k)) 2" using dims_nths_le_n by auto
moreover have "prod_list (replicate l 2) = 2^l" for l by simp
moreover have "{0..<Suc k} ∪ {Suc k} = {0..<(Suc (Suc k))}" by auto
ultimately have plssk: "prod_list (nths dims ({0..<Suc k} ∪ {Suc k})) = 2^(Suc (Suc k))" by auto
show ?thesis apply (rule carrier_vecI) unfolding ket_zero_k.simps Suc
using st.ptensor_vec_dim plssk unfolding st.d0_def st.dims0_def st.vars0_def by auto
qed
lemma H_k_ket_zero_k:
"k < n ⟹ (H_k k) *⇩v (ket_zero_k k) = (ket_plus_k k)"
proof (induct k)
case 0
show ?case using hadamard_on_zero unfolding H_k.simps ket_zero_k.simps ket_plus_k.simps by auto
next
case (Suc k)
then have k: "k < n" by auto
interpret st: partial_state2 dims "{0..<(Suc k)}" "{Suc k}"
apply unfold_locales by auto
have "nths dims {0..<Suc k} = replicate (Suc k) 2" using dims_nths_le_n Suc by auto
then have std1: "st.d1 = 2^(Suc k)" unfolding st.d1_def st.dims1_def by auto
have std2: "st.d2 = 2" unfolding st.d2_def st.dims2_def using dims_nths_one_lt_n Suc by auto
have "H_k (Suc k) *⇩v ket_zero_k (Suc k) = st.ptensor_mat (H_k k) hadamard *⇩v st.ptensor_vec (ket_zero_k k) ket_zero" by auto
also have "… = st.ptensor_vec ((H_k k) *⇩v (ket_zero_k k)) (hadamard *⇩v ket_zero)"
using st.ptensor_mat_mult_vec[unfolded std1 std2, OF H_k_dim[OF k] ket_zero_k_dim[OF k] hadamard_dim ket_zero_dim] by auto
also have "… = st.ptensor_vec (ket_plus_k k) ket_plus" using Suc hadamard_on_zero by auto
finally show ?case by auto
qed
lemma encode1_replicate_2:
"partial_state.encode1 (replicate (Suc k) 2) {0..<k} i = i mod (2 ^ k)"
proof -
have take_Suc: "take k (replicate (Suc k) 2) = replicate k 2"
apply (subst take_replicate) by auto
have take_encode: "take k (digit_encode (replicate (Suc k) 2) i) = digit_encode (replicate k 2) i"
apply (subst digit_encode_take) using take_Suc by metis
show ?thesis
unfolding partial_state.encode1_def partial_state.dims1_def
nths_upt_eq_take[simplified lessThan_atLeast0] take_Suc take_encode
digit_decode_encode prod_list_replicate ..
qed
lemma encode2_replicate_2:
assumes "i < 2 ^ Suc k"
shows "partial_state.encode2 (replicate (Suc k) 2) {0..<k} i = i div (2 ^ k)"
proof -
have drop_Suc: "drop k (replicate (Suc k) 2) = [2]"
apply (subst drop_replicate) by auto
have drop_encode: "drop k (digit_encode (replicate (Suc k) 2) i) = digit_encode [2] (i div (2 ^ k))"
unfolding digit_encode_drop drop_Suc take_replicate prod_list_replicate
by (metis lessI min.strict_order_iff)
have le2: "i div 2 ^ k < 2"
using assms by (auto simp add: less_mult_imp_div_less)
have prod_list_2: "prod_list [2] = 2" by simp
show ?thesis
unfolding partial_state.encode2_def partial_state.dims2_def
nths_minus_upt_eq_drop[simplified lessThan_atLeast0] drop_Suc drop_encode
digit_decode_encode prod_list_2
using le2 by auto
qed
lemma ket_zero_k_decode:
"k < n ⟹ ket_zero_k k = Matrix.vec (2^(Suc k)) (λk. if k = 0 then 1 else 0)"
proof (induct k)
case 0
show ?case apply (rule eq_vecI) by (auto simp add: ket_zero_def)
next
case (Suc k)
then have k: "k < n" by auto
have kzkk: "ket_zero_k k = Matrix.vec (2 ^ Suc k) (λk. if (k = 0) then 1 else 0)" using Suc(1)[OF k] by auto
have dSk: "ket_zero_k (Suc k) ∈ carrier_vec (2^(Suc (Suc k)))" using ket_zero_k_dim[OF Suc(2)] by auto
interpret st: partial_state "replicate (Suc (Suc k)) 2" "{0..<Suc k}".
interpret st2: partial_state2 dims "{0..<Suc k}" "{Suc k}" by (unfold_locales, auto)
have splitset: "({0..<Suc k} ∪ {Suc k}) = {0..<Suc (Suc k)}" by auto
then have st2dims0: "st2.dims0 = replicate (Suc (Suc k)) 2" unfolding st2.dims0_def st2.vars0_def
using dims_nths_le_n[of "Suc (Suc k)"] Suc by auto
have "⋀x. (x ∈ {0..<Suc k} ⟹ {y ∈ {0..<Suc (Suc k)}. y < x} = {0..<x})" by auto
then have cardeq: "⋀x. (x ∈ {0..<Suc k} ⟹ card {y ∈ {0..<Suc (Suc k)}. y < x} = card {0..<x})" by auto
have setcong: "⋀g h I. (⋀x. (x ∈ I ⟹ g x = h x)) ⟹ {g x | x. x ∈ I} = {h x | x. x ∈ I}" by metis
have "{card {y ∈ {0..<Suc (Suc k)}. y < x} |x. x ∈ {0..<Suc k}} = {card {0..<x} |x. x ∈ {0..<Suc k}} "
using setcong[OF cardeq, of "{0..<Suc k}"] by auto
also have "… = {0..<Suc k}" by auto
finally have st2vars1': "st2.vars1' = {0..<Suc k}" unfolding st2.vars1'_def st2.vars0_def splitset ind_in_set_def by fastforce
have st2pvsttv: "st2.ptensor_vec = st.tensor_vec" unfolding st2.ptensor_vec_def using st2dims0 st2vars1' by auto
have "st.encode1 0 = 0" using encode1_replicate_2[of "Suc k" 0] by auto
moreover have "st.encode2 0 = 0" using encode2_replicate_2[of 0 "Suc k"] by auto
moreover have std: "st.d = 2^(Suc (Suc k))" unfolding st.d_def by auto
ultimately have kzkk0: "ket_zero_k (Suc k) $ 0 = 1"
unfolding ket_zero_k.simps st2pvsttv st.tensor_vec_def ket_zero_def using kzkk by auto
have kzkki: "ket_zero_k (Suc k) $ i = 0" if ine0: "i ≠ 0" and ile: "i < 2^(Suc (Suc k))" for i
proof (cases "i mod (2 ^ Suc k) ≠ 0")
case True
then have "ket_zero_k k $ st.encode1 i = 0" unfolding kzkk using encode1_replicate_2[of "Suc k" i] ile by auto
then show ?thesis unfolding ket_zero_k.simps st2pvsttv st.tensor_vec_def ket_zero_def std using ile by auto
next
case False
have "i div (2 ^ Suc k) ≠ 0 ∨ i mod (2 ^ Suc k) ≠ 0" using ine0 by fastforce
then have "i div (2 ^ Suc k) ≠ 0" using False by auto
moreover have "i div (2 ^ Suc k) < 2" using ile less_mult_imp_div_less by auto
ultimately have "i div (2 ^ Suc k) = 1" by auto
then have "st.encode2 i = 1" using encode2_replicate_2[of i "Suc k"] ile by auto
then have "Matrix.vec 2 (λk. if k = 0 then 1 else 0) $ st.encode2 i = 0"
unfolding kzkk by fastforce
then show ?thesis unfolding ket_zero_k.simps st2pvsttv st.tensor_vec_def ket_zero_def std using ile by auto
qed
show ?case apply (rule eq_vecI)
subgoal for i using kzkk0 kzkki by auto
using carrier_vecD[OF dSk] by auto
qed
lemma ket_plus_k_decode:
"k < n ⟹ ket_plus_k k = Matrix.vec (2^(Suc k)) (λl. 1 / csqrt (2^(Suc k)))"
proof (induct k)
case 0
then show ?case unfolding ket_plus_k.simps ket_plus_def by auto
next
case (Suc k)
then have kpkk: "ket_plus_k k = Matrix.vec (2 ^ Suc k) (λl. 1 / csqrt (2 ^ Suc k))" by auto
have dSk: "ket_plus_k (Suc k) ∈ carrier_vec (2^(Suc (Suc k)))" using ket_plus_k_dim[OF Suc(2)] by auto
interpret st: partial_state "replicate (Suc (Suc k)) 2" "{0..<Suc k}".
interpret st2: partial_state2 dims "{0..<Suc k}" "{Suc k}" by (unfold_locales, auto)
have splitset: "({0..<Suc k} ∪ {Suc k}) = {0..<Suc (Suc k)}" by auto
then have st2dims0: "st2.dims0 = replicate (Suc (Suc k)) 2" unfolding st2.dims0_def st2.vars0_def
using dims_nths_le_n[of "Suc (Suc k)"] Suc by auto
have "⋀x. (x ∈ {0..<Suc k} ⟹ {y ∈ {0..<Suc (Suc k)}. y < x} = {0..<x})" by auto
then have cardeq: "⋀x. (x ∈ {0..<Suc k} ⟹ card {y ∈ {0..<Suc (Suc k)}. y < x} = card {0..<x})" by auto
have setcong: "⋀g h I. (⋀x. (x ∈ I ⟹ g x = h x)) ⟹ {g x | x. x ∈ I} = {h x | x. x ∈ I}" by metis
have "{card {y ∈ {0..<Suc (Suc k)}. y < x} |x. x ∈ {0..<Suc k}} = {card {0..<x} |x. x ∈ {0..<Suc k}} "
using setcong[OF cardeq, of "{0..<Suc k}"] by auto
also have "… = {0..<Suc k}" by auto
finally have st2vars1': "st2.vars1' = {0..<Suc k}" unfolding st2.vars1'_def st2.vars0_def splitset ind_in_set_def by blast
have st2pvsttv: "st2.ptensor_vec = st.tensor_vec" unfolding st2.ptensor_vec_def using st2dims0 st2vars1' by auto
have "csqrt (2 ^ (Suc k)) = complex_of_real (sqrt (2 ^ (Suc k)))" by simp
moreover have "complex_of_real (sqrt (2 ^ (Suc k))) * complex_of_real (sqrt 2) = complex_of_real (sqrt (2 ^ (Suc (Suc k))))"
by (metis of_real_mult power_Suc power_commutes real_sqrt_power)
ultimately have "csqrt (2 ^ (Suc k)) * csqrt 2 = csqrt (2 ^ (Suc (Suc k)))" by auto
moreover have "1 / csqrt (2 ^ Suc k) * 1 / csqrt 2 = 1 / (csqrt (2 ^ (Suc k)) * csqrt 2)" by simp
ultimately have csqrt2p :"1 / csqrt (2 ^ Suc k) * 1 / csqrt 2 = 1 / (csqrt (2 ^ (Suc (Suc k))))" by simp
have std: "st.d = 2^(Suc (Suc k))" unfolding st.d_def by auto
have nthsSSk2: "nths (replicate (Suc (Suc k)) 2) {0..<Suc k} = replicate (Suc k) 2"
unfolding nths_replicate[of "Suc (Suc k)" 2 "{0..<Suc k}"]
by (smt Collect_cong ‹{card {0..<x} |x. x ∈ {0..<Suc k}} = {0..<Suc k}› atLeastLessThan_iff card_atLeastLessThan diff_zero less_SucI)
then have std1: "st.d1 = 2^(Suc k)" unfolding st.d1_def st.dims1_def nthsSSk2 by auto
have "{i. i < Suc (Suc k) ∧ i ∈ {Suc k..}} = {Suc k}" by auto
then have "nths (replicate (Suc (Suc k)) 2) ({Suc k..}) = replicate 1 2" unfolding nths_replicate by auto
moreover have "(- {0..<Suc k}) = {Suc k..}" by auto
ultimately have nthsSSk2c: "nths (replicate (Suc (Suc k)) 2) (- {0..<Suc k}) = replicate 1 2" by auto
have std2: "st.d2 = 2" unfolding st.d2_def st.dims2_def apply (subst nthsSSk2c) by auto
have "st.encode1 i < st.d1" if "i < st.d" for i using that st.encode1_lt[OF that] by auto
then have kpkki: "ket_plus_k k $ st.encode1 i = 1 / csqrt (2^(Suc k))" if "i < st.d" for i unfolding kpkk std1 using that by auto
have "st.encode2 i < st.d2" if "i < st.d" for i using that st.encode2_lt[OF that] by auto
then have kpi: "ket_plus $ st.encode2 i = 1 / csqrt 2" if "i < st.d" for i unfolding ket_plus_def std2 using that by auto
have kzkki: "ket_plus_k (Suc k) $ i = 1 / (csqrt (2 ^ (Suc (Suc k))))" if "i < st.d" for i
unfolding ket_plus_k.simps st2pvsttv st.tensor_vec_def using csqrt2p kpkki kpi that by auto
show ?case apply (rule eq_vecI)
subgoal for i using kzkki unfolding std by auto
using carrier_vecD[OF dSk] by auto
qed
lemma exH_k_mult_pre_is_psi:
"exH_k (n - 1) *⇩v ket_pre = ψ"
proof -
have "exH_k (n - 1) = H_k (n - 1)" using exH_eq_H by auto
moreover have "ket_zero_k (n - 1) = ket_pre" using ket_zero_k_decode[of "n - 1"] ket_pre_def N_def n by auto
moreover have "ket_plus_k (n - 1) = ψ" using ket_plus_k_decode[of "n - 1"] ψ_def N_def n by auto
moreover have "H_k (n - 1) *⇩v ket_zero_k (n - 1) = ket_plus_k (n - 1)" using H_k_ket_zero_k n by auto
ultimately show ?thesis by auto
qed
definition ket_k :: "nat ⇒ complex vec" where
"ket_k x = Matrix.vec K (λk. if k = x then 1 else 0)"
lemma ket_k_dim:
"ket_k k ∈ carrier_vec K"
unfolding ket_k_def by auto
lemma mat_incr_mult_ket_k:
"k < K ⟹ (mat_incr K) *⇩v (ket_k k) = (ket_k ((k + 1) mod K))"
apply (rule eq_vecI)
unfolding mat_incr_def ket_k_def
apply (simp add: scalar_prod_def)
apply (case_tac "k = K - 1")
subgoal for i apply auto by (simp add: sum_only_one_neq_0[of _ "K - 1"])
subgoal for i apply auto by (simp add: sum_only_one_neq_0[of _ "i - 1"])
by auto
definition proj_k where
"proj_k x = proj (ket_k x)"
lemma proj_k_dim:
"proj_k k ∈ carrier_mat K K"
unfolding proj_k_def using ket_k_dim by auto
lemma norm_ket_k_lt_K:
"k < K ⟹ inner_prod (ket_k k) (ket_k k) = 1"
unfolding ket_k_def apply (simp add: scalar_prod_def)
using sum_only_one_neq_0[of "{0..<K}" k "λi. (if i = k then 1 else 0) * cnj (if i = k then 1 else 0)"] by auto
lemma norm_ket_k_ge_K:
"k ≥ K ⟹ inner_prod (ket_k k) (ket_k k) = 0"
unfolding ket_k_def by (simp add: scalar_prod_def)
lemma norm_ket_k:
"inner_prod (ket_k k) (ket_k k) ≤ 1"
apply (case_tac "k < K")
using norm_ket_k_lt_K norm_ket_k_ge_K by auto
lemma proj_k_mat:
assumes "k < K"
shows "proj_k k = mat K K (λ(i, j). if (i = j ∧ i = k) then 1 else 0)"
apply (rule eq_matI)
apply (simp add: proj_k_def ket_k_def index_outer_prod)
using proj_k_dim by auto
lemma positive_proj_k:
"positive (proj_k k)"
using positive_same_outer_prod unfolding proj_k_def ket_k_def by auto
lemma proj_k_le_one:
"(proj_k k) ≤⇩L 1⇩m K"
unfolding proj_k_def using outer_prod_le_one norm_ket_k ket_k_def by auto
definition proj_psi where
"proj_psi = proj ψ"
lemma proj_psi_dim:
"proj_psi ∈ carrier_mat N N"
unfolding proj_psi_def ψ_def by auto
lemma norm_psi:
"inner_prod ψ ψ = 1"
apply (simp add: ψ_eval scalar_prod_def)
by (metis norm_of_nat norm_of_real of_real_mult of_real_of_nat_eq real_sqrt_mult_self)
lemma proj_psi_mat:
"proj_psi = mat N N (λk. 1 / N)"
unfolding proj_psi_def
apply (rule eq_matI, simp_all)
apply (simp add: ψ_def index_outer_prod)
apply (smt of_nat_less_0_iff of_real_of_nat_eq of_real_power power2_eq_square real_sqrt_pow2)
by (auto simp add: carrier_matD[OF outer_prod_dim[OF ψ_dim(1) ψ_dim(1)]])
lemma hermitian_proj_psi:
"hermitian proj_psi"
unfolding hermitian_def proj_psi_mat apply (rule eq_matI)
by (auto simp add: adjoint_eval)
lemma hermitian_exproj_psi:
"hermitian (tensor_P proj_psi (1⇩m K))"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_hermitian)
using proj_psi_dim ps_P_d1 ps_P_d2 hermitian_proj_psi hermitian_one by auto
lemma proj_psi_is_projection:
"proj_psi * proj_psi = proj_psi"
proof -
have "proj_psi * proj_psi = inner_prod ψ ψ ⋅⇩m proj_psi"
unfolding proj_psi_def
apply (subst outer_prod_mult_outer_prod) using ψ_def by auto
also have "… = proj_psi"
using ψ_inner by auto
finally show ?thesis.
qed
lemma proj_psi_trace:
"trace (proj_psi) = 1"
unfolding proj_psi_def
apply (subst trace_outer_prod[of _ N])
subgoal unfolding ψ_def by auto using norm_psi by auto
lemma positive_proj_psi:
"positive (proj_psi)"
using positive_same_outer_prod unfolding proj_psi_def ψ_def by auto
lemma proj_psi_le_one:
"(proj_psi) ≤⇩L 1⇩m N"
unfolding proj_psi_def using outer_prod_le_one norm_psi ψ_def by auto
lemma hermitian_hadamard_on_k:
assumes "k < n"
shows "hermitian (hadamard_on_i k)"
proof -
interpret st2: partial_state2 dims "{k}" "(vars1 - {k})"
apply unfold_locales by auto
have st2d1: "st2.dims1 = [2]" unfolding st2.dims1_def dims_def
using assms dims_nths_one_lt_n local.dims_def st2.dims1_def by auto
show "hermitian (hadamard_on_i k)" unfolding hadamard_on_i_def st2.pmat_extension_def st2.ptensor_mat_def
apply (rule partial_state.tensor_mat_hermitian)
subgoal unfolding partial_state.d1_def partial_state.dims1_def st2.nths_vars1' hadamard_def by (simp add: st2d1)
subgoal unfolding partial_state.d2_def partial_state.dims2_def st2.nths_vars2' st2.d2_def by auto
subgoal unfolding hermitian_def hadamard_def apply (rule eq_matI) by (auto simp add: adjoint_dim adjoint_eval)
using hermitian_one by auto
qed
lemma hermitian_H_k:
"k < n ⟹ hermitian (H_k k)"
proof (induct k)
case 0
show ?case unfolding H_k.simps hermitian_def hadamard_def apply (rule eq_matI) by (auto simp add: adjoint_dim adjoint_eval)
next
case (Suc k)
interpret st2: partial_state2 dims "{0..<Suc k}" "{Suc k}"
apply unfold_locales by auto
have st2d1: "prod_list st2.dims1 = (2^(Suc k))" unfolding st2.dims1_def dims_def using Suc(2)
using dims_nths_le_n local.dims_def st2.dims1_def by auto
have st2d2: "st2.dims2 = [2]" unfolding st2.dims2_def dims_def using Suc(2)
using dims_nths_one_lt_n local.dims_def st2.dims2_def by auto
show ?case unfolding H_k.simps st2.ptensor_mat_def
apply (rule partial_state.tensor_mat_hermitian)
subgoal unfolding partial_state.d1_def partial_state.dims1_def st2.nths_vars1' using st2d1 H_k_dim Suc by auto
subgoal unfolding partial_state.d2_def partial_state.dims2_def st2.nths_vars2' st2.d2_def using st2d2 by (simp add: hadamard_def)
subgoal using Suc by auto
using hermitian_hadamard by auto
qed
lemma unitary_H_k:
"k < n ⟹ unitary (H_k k)"
proof (induct k)
case 0
show ?case using unitary_hadamard by auto
next
case (Suc k)
then have k: "k < n" by auto
interpret st2: partial_state2 dims "{0..<Suc k}" "{Suc k}" by (unfold_locales, auto)
have st2d1: "prod_list st2.dims1 = (2^(Suc k))" unfolding st2.dims1_def dims_def using Suc(2)
using dims_nths_le_n local.dims_def st2.dims1_def by auto
have st2d2: "st2.dims2 = [2]" unfolding st2.dims2_def dims_def using Suc(2)
using dims_nths_one_lt_n local.dims_def st2.dims2_def by auto
show ?case unfolding H_k.simps st2.ptensor_mat_def
apply (rule partial_state.tensor_mat_unitary[of "H_k k" st2.dims0 st2.vars1' hadamard] )
unfolding partial_state.d1_def partial_state.dims1_def st2.nths_vars1' partial_state.d2_def partial_state.dims2_def
st2.nths_vars2'
apply (auto simp add: st2d1 st2d2 )
subgoal using H_k_dim[OF k] by auto
subgoal using hadamard_dim by auto
subgoal using Suc by auto
using unitary_hadamard by auto
qed
lemma exH_k_dim:
shows "k < n ⟹ exH_k k ∈ carrier_mat N N"
apply (induct k)
using hadamard_on_i_dim by auto
lemma exH_n_dim:
shows "exH_k (n - 1) ∈ carrier_mat N N"
using exH_k_dim n by auto
lemma unitary_exH_k:
shows "k < n ⟹ unitary (exH_k k)"
proof (induct k)
case 0
then show ?case unfolding exH_k.simps using unitary_hadamard_on_i 0 by auto
next
case (Suc k)
show ?case unfolding exH_k.simps apply (subst unitary_times_unitary[of _ N])
subgoal using exH_k_dim Suc by auto
subgoal using hadamard_on_i_dim Suc by auto
subgoal using Suc by auto
using unitary_hadamard_on_i Suc by auto
qed
lemma hermitian_exH_n:
"hermitian (exH_k (n - 1))"
using hermitian_H_k exH_eq_H n by auto
lemma exH_k_mult_psi_is_pre:
"exH_k (n - 1) *⇩v ψ = ket_pre"
proof -
let ?H = "exH_k (n - 1)"
have "hermitian ?H" using hermitian_H_k exH_eq_H n by auto
then have eqad: "adjoint ?H = ?H" unfolding hermitian_def by auto
have d: "?H ∈ carrier_mat N N" using exH_k_dim n by auto
have "unitary ?H" using unitary_exH_k n by auto
then have id: "?H * ?H = 1⇩m N"
unfolding unitary_def inverts_mat_def
using d apply (subst (2) eqad[symmetric]) by auto
have "?H *⇩v ψ = ?H *⇩v (?H *⇩v ket_pre)"
using exH_k_mult_pre_is_psi by auto
also have "… = (?H * ?H) *⇩v ket_pre"
using d ket_pre_def by auto
also have "… = ket_pre"
using id ket_pre_def by auto
finally show ?thesis by auto
qed
fun exexH_k :: "nat ⇒ complex mat" where
"exexH_k k = tensor_P (exH_k k) (1⇩m K)"
lemma unitary_exexH_k:
"k < n ⟹ unitary (exexH_k k)"
unfolding exexH_k.simps ps2_P.ptensor_mat_def
apply (subst partial_state.tensor_mat_unitary)
subgoal using exH_k_dim unfolding partial_state.d1_def partial_state.dims1_def ps2_P.nths_vars1' ps2_P.dims1_def dims_vars1 N_def by auto
subgoal unfolding partial_state.d2_def partial_state.dims2_def ps2_P.nths_vars2' ps2_P.dims2_def dims_vars2 by auto
using unitary_exH_k unitary_one by auto
lemma exexH_k_dim:
"k < n ⟹ exexH_k k ∈ carrier_mat d d"
unfolding exexH_k.simps using ps2_P.ptensor_mat_carrier ps2_P_d0 by auto
lemma hoare_seq_utrans:
fixes P :: "complex mat"
assumes "unitary U1" and "unitary U2" and "is_quantum_predicate P"
and dU1: "U1 ∈ carrier_mat d d" and dU2: "U2 ∈ carrier_mat d d"
shows "
⊢⇩p
{adjoint (U2 * U1) * P * (U2 * U1)}
Utrans U1;; Utrans U2
{P}"
proof -
have hp0: "⊢⇩p {adjoint (U2) * P * (U2)} Utrans U2 {P}"
using assms hoare_partial.intros by auto
have qp: "is_quantum_predicate (adjoint (U2) * P * (U2))"
using qp_close_under_unitary_operator assms by auto
then have hp1: "⊢⇩p {adjoint U1 * (adjoint (U2) * P * (U2)) * U1} Utrans U1 {adjoint (U2) * P * (U2)}"
using hoare_partial.intros by auto
have dP: "P ∈ carrier_mat d d" using assms is_quantum_predicate_def by auto
have eq: "adjoint U1 * (adjoint U2 * P * U2) * U1 = adjoint (U2 * U1) * P * (U2 * U1)"
using dU1 dU2 dP by (mat_assoc d)
with hp1 have hp2: "⊢⇩p {adjoint (U2 * U1) * P * (U2 * U1)} Utrans U1 {adjoint (U2) * P * (U2)}" by auto
have "is_quantum_predicate (adjoint U1 * (adjoint U2 * P * U2) * U1)" using qp qp_close_under_unitary_operator assms by auto
then have "is_quantum_predicate (adjoint (U2 * U1) * P * (U2 * U1))" using eq by auto
then show ?thesis using hoare_partial.intros(3)[OF _ qp assms(3)] hp0 hp2 by auto
qed
lemma qp_close_after_exexH_k:
fixes P :: "complex mat"
assumes "is_quantum_predicate P"
shows "k < n ⟹ is_quantum_predicate (adjoint (exexH_k k) * P * exexH_k k)"
apply (subst qp_close_under_unitary_operator)
subgoal using exexH_k_dim by auto
subgoal using unitary_exexH_k by auto
using assms by auto
lemma hoare_hadamard_n:
fixes P :: "complex mat"
shows "is_quantum_predicate P ⟹ k < n ⟹
⊢⇩p
{adjoint (exexH_k k) * P * exexH_k k}
hadamard_n (Suc k)
{P}"
proof (induct k arbitrary: P)
case 0
have qp: "is_quantum_predicate (adjoint (exexH_k 0) * P * exexH_k 0)"
using qp_close_under_unitary_operator[OF _ unitary_exhadamard_on_i[of 0]] tensor_P_dim 0 by auto
then have "⊢⇩p {adjoint (exexH_k 0) * P * exexH_k 0} SKIP {adjoint (exexH_k 0) * P * exexH_k 0}"
using hoare_partial.intros(1) by auto
moreover have "⊢⇩p {adjoint (exexH_k 0) * P * exexH_k 0} Utrans (tensor_P (hadamard_on_i 0) (1⇩m K)) {P}"
using hoare_partial.intros(2) 0 by auto
ultimately have "⊢⇩p {adjoint (exexH_k 0) * P * exexH_k 0} SKIP;; Utrans (tensor_P (hadamard_on_i 0) (1⇩m K)) {P}"
using hoare_partial.intros(3) qp 0 by auto
then show ?case using qp by auto
next
case (Suc k)
have h1: "⊢⇩p
{adjoint (tensor_P (hadamard_on_i (Suc k)) (1⇩m K)) * P * (tensor_P (hadamard_on_i (Suc k)) (1⇩m K))}
Utrans (tensor_P (hadamard_on_i (Suc k)) (1⇩m K))
{P}"
using hoare_partial.intros Suc by auto
have qp: "is_quantum_predicate (adjoint (tensor_P (hadamard_on_i (Suc k)) (1⇩m K)) * P * (tensor_P (hadamard_on_i (Suc k)) (1⇩m K)))"
apply (subst qp_close_under_unitary_operator)
subgoal using ps2_P.ptensor_mat_carrier ps2_P_d0 by auto
subgoal unfolding ps2_P.ptensor_mat_def apply (subst partial_state.tensor_mat_unitary )
subgoal unfolding partial_state.d1_def partial_state.dims1_def ps2_P.nths_vars1' ps2_P.dims1_def d_vars1 using hadamard_on_i_dim Suc by auto
subgoal unfolding partial_state.d2_def partial_state.dims2_def ps2_P.nths_vars2' ps2_P.dims2_def using dims_vars2 by auto
using unitary_hadamard_on_i unitary_one Suc by auto
using Suc by auto
then have h2: "⊢⇩p
{adjoint (exexH_k k) * (adjoint (tensor_P (hadamard_on_i (Suc k)) (1⇩m K)) * P * (tensor_P (hadamard_on_i (Suc k)) (1⇩m K))) * exexH_k k}
hadamard_n (Suc k)
{adjoint (tensor_P (hadamard_on_i (Suc k)) (1⇩m K)) * P * (tensor_P (hadamard_on_i (Suc k)) (1⇩m K))}"
using Suc by auto
have "(tensor_P (hadamard_on_i (Suc k)) (1⇩m K)) * exexH_k k
= (tensor_P (hadamard_on_i (Suc k) * (exH_k k)) (1⇩m K * (1⇩m K)))"
apply (subst ps2_P.ptensor_mat_mult)
subgoal using hadamard_on_i_dim ps2_P_d1 Suc by auto
subgoal using exH_k_dim ps2_P_d1 Suc by auto
using ps2_P_d2 by auto
also have "… = exexH_k (Suc k)" using mult_exH_k_left Suc by auto
finally have eq1: "(tensor_P (hadamard_on_i (Suc k)) (1⇩m K)) * exexH_k k = exexH_k (Suc k)".
then have eq2: "adjoint (exexH_k k) * adjoint (tensor_P (hadamard_on_i (Suc k)) (1⇩m K)) = adjoint (exexH_k (Suc k))"
apply (subst adjoint_mult[symmetric, of _ d d _ d])
subgoal using tensor_P_dim by auto
using exexH_k_dim Suc by auto
have dP: "P ∈ carrier_mat d d" using is_quantum_predicate_def Suc by auto
moreover have dH: "exexH_k k ∈ carrier_mat d d" using exexH_k_dim Suc by auto
moreover have dHi: "tensor_P (hadamard_on_i (Suc k)) (1⇩m K) ∈ carrier_mat d d" using tensor_P_dim by auto
ultimately have eq3: "adjoint (exexH_k k) * (adjoint (tensor_P (hadamard_on_i (Suc k)) (1⇩m K)) * P * tensor_P (hadamard_on_i (Suc k)) (1⇩m K)) * exexH_k k
= (adjoint (exexH_k k) * adjoint (tensor_P (hadamard_on_i (Suc k)) (1⇩m K))) * P * (tensor_P (hadamard_on_i (Suc k)) (1⇩m K) * exexH_k k)"
by (mat_assoc d)
show ?case apply (subst hadamard_n.simps)
apply (subst hoare_partial.intros(3)[of _ "adjoint (tensor_P (hadamard_on_i (Suc k)) (1⇩m K)) * P * (tensor_P (hadamard_on_i (Suc k)) (1⇩m K))"])
subgoal using qp_close_after_exexH_k[of P "Suc k"] Suc by auto
subgoal using qp by auto
subgoal using Suc by auto
subgoal using h2[simplified eq3 eq1 eq2] by auto
using h1 by auto
qed
lemma qp_pre:
"is_quantum_predicate (tensor_P pre (proj_k 0))"
unfolding is_quantum_predicate_def
proof (intro conjI)
show "tensor_P pre (proj_k 0) ∈ carrier_mat d d" using tensor_P_dim by auto
interpret st: partial_state dims vars1 .
have d1: "st.d1 = N" unfolding st.d1_def st.dims1_def using d_vars1 by auto
have d2: "st.d2 = K" unfolding st.d2_def st.dims2_def nths_uminus_vars1 dims_vars2 by auto
show "positive (tensor_P pre (proj_k 0))"
unfolding ps2_P.ptensor_mat_def ps2_P_dims0 ps2_P_vars1'
apply (subst st.tensor_mat_positive)
subgoal unfolding pre_def using outer_prod_dim ket_pre_def d1 by auto
subgoal unfolding proj_k_def using outer_prod_dim ket_k_def d2 by auto
subgoal using positive_pre by auto
using positive_proj_k[of 0] K_gt_0 by auto
show "tensor_P pre (proj_k 0) ≤⇩L 1⇩m d"
unfolding ps2_P.ptensor_mat_def ps2_P_dims0 ps2_P_vars1'
apply (subst st.tensor_mat_le_one)
subgoal using pre_def ket_pre_def outer_prod_dim d1 by auto
subgoal using proj_k_def K_gt_0 ket_k_def outer_prod_dim d2 by auto
using d1 d2 K_gt_0 outer_prod_dim positive_pre positive_proj_k pre_le_one proj_k_le_one by auto
qed
lemma qp_init_post:
"is_quantum_predicate (tensor_P proj_psi (proj_k 0))"
unfolding is_quantum_predicate_def
proof (intro conjI)
show "tensor_P proj_psi (proj_k 0) ∈ carrier_mat d d" using tensor_P_dim by auto
interpret st: partial_state dims vars1 .
have d1: "st.d1 = N" unfolding st.d1_def st.dims1_def using d_vars1 by auto
have d2: "st.d2 = K" unfolding st.d2_def st.dims2_def nths_uminus_vars1 dims_vars2 by auto
show "positive (tensor_P proj_psi (proj_k 0))"
unfolding ps2_P.ptensor_mat_def ps2_P_dims0 ps2_P_vars1'
apply (subst st.tensor_mat_positive)
subgoal unfolding proj_psi_def using outer_prod_dim ψ_def d1 by auto
subgoal unfolding proj_k_def using outer_prod_dim ket_k_def d2 by auto
subgoal using positive_proj_psi by auto
using positive_proj_k[of 0] K_gt_0 by auto
show "tensor_P proj_psi (proj_k 0) ≤⇩L 1⇩m d"
unfolding ps2_P.ptensor_mat_def ps2_P_dims0 ps2_P_vars1'
apply (subst st.tensor_mat_le_one)
subgoal using proj_psi_def outer_prod_dim d1 by auto
subgoal using proj_k_def K_gt_0 ket_k_def outer_prod_dim d2 by auto
using d1 d2 K_gt_0 outer_prod_dim positive_proj_psi positive_proj_k proj_psi_le_one proj_k_le_one by auto
qed
lemma tensor_P_adjoint_left_right:
assumes "m1 ∈ carrier_mat N N" and "m2 ∈ carrier_mat K K" and "m3 ∈ carrier_mat N N" and "m4 ∈ carrier_mat K K"
shows "adjoint (tensor_P m1 m2) * tensor_P m3 m4 * tensor_P m1 m2 = tensor_P (adjoint m1 * m3 * m1) (adjoint m2 * m4 * m2)"
proof -
have eq1: "adjoint (tensor_P m1 m2) = tensor_P (adjoint m1) (adjoint m2)"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_adjoint)
using ps_P_d1 ps_P_d2 assms by auto
have eq2: "adjoint (tensor_P m1 m2) * tensor_P m3 m4 = tensor_P (adjoint m1 * m3) (adjoint m2 * m4)"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_mult)
using ps_P_d1 ps_P_d2 assms eq1 unfolding ps2_P.ptensor_mat_def by (auto simp add: adjoint_dim)
have eq3: "tensor_P (adjoint m1 * m3) (adjoint m2 * m4) * (tensor_P m1 m2) = tensor_P (adjoint m1 * m3 * m1) (adjoint m2 * m4 * m2)"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_mult[of "adjoint m1 * m3"])
using ps_P_d1 ps_P_d2 assms by (auto simp add: adjoint_dim)
show ?thesis using eq1 eq2 eq3 by auto
qed
abbreviation exH_n where
"exH_n ≡ exH_k (n - 1)"
lemma hoare_triple_init:
"⊢⇩p
{tensor_P pre (proj_k 0)}
hadamard_n n
{tensor_P proj_psi (proj_k 0)}"
proof -
have h: "⊢⇩p
{adjoint (exexH_k (n - 1)) * (tensor_P proj_psi (proj_k 0)) * (exexH_k (n - 1))}
hadamard_n n
{tensor_P proj_psi (proj_k 0)}"
using hoare_hadamard_n[OF qp_init_post, of "n - 1"] qp_init_post n by auto
have "adjoint (exexH_k (n - 1)) * tensor_P proj_psi (proj_k 0) * exexH_k (n - 1) =
tensor_P (adjoint exH_n * proj_psi * exH_n) (adjoint (1⇩m K) * proj_k 0 * 1⇩m K)"
unfolding exexH_k.simps
apply (subst tensor_P_adjoint_left_right)
using exH_k_dim proj_psi_def ψ_def proj_k_def ket_k_def n by (auto)
moreover have "adjoint exH_n * proj_psi * exH_n = pre"
unfolding proj_psi_def pre_def
apply (subst outer_prod_left_right_mat[of _ N _ N _ N _ N])
subgoal using ψ_def by auto
subgoal using exH_k_dim n by (simp add: adjoint_dim)
subgoal using exH_k_dim n by simp
apply (subst (1 2) hermitian_exH_n[simplified hermitian_def])
apply (subst (1 2) exH_k_mult_psi_is_pre)
by auto
moreover have "adjoint (1⇩m K) * (proj_k 0) * (1⇩m K) = proj_k 0"
apply (subst adjoint_one) using proj_k_dim[of 0] K_gt_0 by auto
ultimately have "adjoint (exexH_k (n - 1)) * tensor_P proj_psi (proj_k 0) * exexH_k (n - 1) = tensor_P pre (proj_k 0)"
by auto
with h show ?thesis by auto
qed
text ‹Hoare triples of while loop›
definition proj_psi_l where
"proj_psi_l l = proj (psi_l l)"
lemma positive_psi_l:
"k < K ⟹ positive (proj_psi_l k)"
unfolding proj_psi_l_def
apply (subst positive_same_outer_prod)
using psi_l_dim by auto
lemma hermitian_proj_psi_l:
"k < K ⟹ hermitian (proj_psi_l k)"
using positive_psi_l positive_is_hermitian by auto
definition P' where
"P' = tensor_P (proj_psi_l R) (proj_k R)"
lemma proj_psi_l_dim:
"proj_psi_l l ∈ carrier_mat N N"
unfolding proj_psi_l_def using psi_l_def by auto
definition Q :: "complex mat" where
"Q = matrix_sum d (λl. tensor_P (proj_psi_l l) (proj_k l)) R"
lemma psi_l_le_id:
shows "proj_psi_l l ≤⇩L 1⇩m N"
proof -
have "inner_prod (psi_l l) (psi_l l) = 1"
using inner_psi_l by auto
then show ?thesis using outer_prod_le_one psi_l_def proj_psi_l_def by auto
qed
lemma positive_proj_psi_l:
shows "positive (proj_psi_l l)"
using positive_same_outer_prod proj_psi_l_def psi_l_dim by auto
definition proj_fst_k :: "nat ⇒ complex mat" where
"proj_fst_k k = mat K K (λ(i, j). if (i = j ∧ i < k) then 1 else 0)"
lemma hermitian_proj_fst_k:
"adjoint (proj_fst_k k) = proj_fst_k k"
by (auto simp add: proj_fst_k_def adjoint_eval)
lemma proj_fst_k_is_projection:
"proj_fst_k k * proj_fst_k k = proj_fst_k k"
by (auto simp add: proj_fst_k_def scalar_prod_def sum_only_one_neq_0)
lemma positive_proj_fst_k:
"positive (proj_fst_k k)"
proof -
have "(proj_fst_k k) * adjoint (proj_fst_k k) = (proj_fst_k k)"
using hermitian_proj_fst_k proj_fst_k_is_projection by auto
then have "∃M. M * adjoint M = (proj_fst_k k)" by auto
then show ?thesis apply (subst positive_if_decomp) using proj_fst_k_def by auto
qed
lemma proj_fst_k_le_one:
"proj_fst_k k ≤⇩L 1⇩m K"
proof -
define M where "M l = mat K K (λ(i, j). if (i = j ∧ i ≥ l) then (1::complex) else 0)" for l
have eq: "1⇩m K - proj_fst_k k = M k" unfolding M_def proj_fst_k_def
apply (rule eq_matI) by auto
have "M k * M k = M k" unfolding M_def
apply (rule eq_matI) apply (simp add: scalar_prod_def)
apply (subst sum_only_one_neq_0[of _ j]) by auto
moreover have "adjoint (M k) = M k" unfolding M_def
apply (rule eq_matI) by (auto simp add: adjoint_eval)
ultimately have "M k * adjoint (M k) = M k" by auto
then have "∃M. M * adjoint M = 1⇩m K - proj_fst_k k" using eq by auto
then have "positive (1⇩m K - proj_fst_k k)"
apply (subst positive_if_decomp) using proj_fst_k_def by auto
then show ?thesis unfolding lowner_le_def using proj_fst_k_def by auto
qed
lemma sum_proj_k:
assumes "m ≤ K"
shows "matrix_sum K (λk. proj_k k) m = proj_fst_k m"
proof -
have "m ≤ K ⟹ matrix_sum K (λk. proj_k k) m = mat K K (λ(i, j). if (i = j ∧ i < m) then 1 else 0)" for m
proof (induct m)
case 0
then show ?case apply simp apply (rule eq_matI) by auto
next
case (Suc m)
then have m: "m < K" by auto
then have m': "m ≤ K" by auto
have "matrix_sum K proj_k (Suc m) = proj_k m + matrix_sum K proj_k m" by simp
also have "… = mat K K (λ(i, j). if (i = j ∧ i < (Suc m)) then 1 else 0)"
unfolding proj_k_mat[OF m] Suc(1)[OF m'] apply (rule eq_matI) by auto
finally show ?case by auto
qed
then show ?thesis unfolding proj_fst_k_def using assms by auto
qed
lemma proj_psi_proj_k_le_exproj_k:
shows "tensor_P (proj_psi_l k) (proj_k l) ≤⇩L tensor_P (1⇩m N) (proj_k l)"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_positive_le)
subgoal using proj_psi_l_def psi_l_dim ps_P_d1 by auto
subgoal using proj_k_def ket_k_def ps_P_d2 by auto
subgoal using positive_proj_psi_l by auto
subgoal using positive_same_outer_prod proj_k_def ket_k_def by auto
subgoal using psi_l_le_id by auto
apply (subst lowner_le_refl[of _ K]) by (auto simp add: proj_k_def ket_k_def)
definition Q1 :: "complex mat" where
"Q1 = matrix_sum d (λl. tensor_P (proj_psi'_l l) (proj_k l)) R"
lemma tensor_P_left_right_partial1:
assumes "m1 ∈ carrier_mat N N" and "m2 ∈ carrier_mat N N" and "m3 ∈ carrier_mat K K" and "m4 ∈ carrier_mat N N"
shows "tensor_P m1 (1⇩m K) * tensor_P m2 m3 * tensor_P m4 (1⇩m K) = tensor_P (m1 * m2 * m4) m3"
proof -
have "tensor_P m1 (1⇩m K) * tensor_P m2 m3 = tensor_P (m1 * m2) m3"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_mult[symmetric])
using assms ps_P_d1 ps_P_d2 by auto
moreover have "tensor_P (m1 * m2) m3 * tensor_P m4 (1⇩m K) = tensor_P (m1 * m2 * m4) m3"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_mult[symmetric])
using assms ps_P_d1 ps_P_d2 by auto
ultimately show ?thesis by auto
qed
lemma tensor_P_left_right_partial2:
assumes "m1 ∈ carrier_mat K K" and "m2 ∈ carrier_mat K K" and "m3 ∈ carrier_mat N N" and "m4 ∈ carrier_mat K K"
shows "tensor_P (1⇩m N) m1 * tensor_P m3 m2 * tensor_P (1⇩m N) m4 = tensor_P m3 (m1 * m2 * m4)"
proof -
have "tensor_P (1⇩m N) m1 * tensor_P m3 m2 = tensor_P m3 (m1 * m2)"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_mult[symmetric])
using assms ps_P_d1 ps_P_d2 by auto
moreover have "tensor_P m3 (m1 * m2) * tensor_P (1⇩m N) m4 = tensor_P m3 (m1 * m2 * m4)"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_mult[symmetric])
using assms ps_P_d1 ps_P_d2 by auto
ultimately show ?thesis by auto
qed
lemma matrix_sum_mult_left_right:
fixes A B :: "complex mat"
assumes dg: "(⋀k. k < l ⟹ g k ∈ carrier_mat m m) "
and dA: "A ∈ carrier_mat m m" and dB: "B ∈ carrier_mat m m"
shows "matrix_sum m (λk. A * g k * B) l = A * matrix_sum m g l * B"
proof -
have eq: "A * matrix_sum m g l = matrix_sum m (λk. A * g k) l"
using matrix_sum_distrib_left assms by auto
have "A * matrix_sum m g l * B = matrix_sum m (λk. A * g k * B) l"
apply (subst eq)
using matrix_sum_mult_right[of l "λk. A * g k"] assms by auto
then show ?thesis by auto
qed
lemma mat_O_split:
"mat_O = 1⇩m N - 2 ⋅⇩m proj_O"
apply (rule eq_matI)
unfolding mat_O_def proj_O_def by auto
lemma mat_O_mult_psi'_l:
"mat_O *⇩v (psi'_l l) = psi_l l"
proof -
have "mat_O *⇩v (psi'_l l) = mat_O *⇩v ((alpha_l l) ⋅⇩v α) - mat_O *⇩v ((beta_l l) ⋅⇩v β)"
unfolding psi'_l_def apply (subst mult_minus_distrib_mat_vec)
using mat_O_dim α_dim β_dim by auto
also have "… = (alpha_l l) ⋅⇩v (mat_O *⇩v α) - (beta_l l) ⋅⇩v (mat_O *⇩v β)"
using mult_mat_vec_smult_vec_assoc[of mat_O N N] mat_O_dim α_dim β_dim by auto
also have "… = (alpha_l l) ⋅⇩v α - (beta_l l) ⋅⇩v (- β)"
using mat_O_mult_alpha mat_O_mult_beta by auto
also have "… = (alpha_l l) ⋅⇩v α + (beta_l l) ⋅⇩v β"
by auto
finally show ?thesis unfolding psi_l_def by auto
qed
lemma mat_O_times_Q1:
"adjoint (tensor_P mat_O (1⇩m K)) * Q1 * (tensor_P mat_O (1⇩m K)) = Q"
proof -
let ?m1 = "tensor_P mat_O (1⇩m K)"
have eq:"adjoint ?m1 = ?m1"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_adjoint)
apply (auto simp add: mat_O_dim ps_P_d1 ps_P_d2)
by (simp add: hermitian_mat_O[unfolded hermitian_def] hermitian_one[unfolded hermitian_def])
{
fix l
let ?m2 = "tensor_P (proj_psi'_l l) (proj_k l)"
have "?m1 * ?m2 * ?m1 = tensor_P (mat_O * (proj_psi'_l l) * mat_O) (proj_k l)"
apply (subst tensor_P_left_right_partial1)
using mat_O_dim proj_psi'_dim proj_k_dim by auto
moreover have "mat_O * (proj_psi'_l l) * mat_O = outer_prod (psi_l l) (psi_l l)"
unfolding proj_psi'_l_def apply (subst outer_prod_left_right_mat[of _ N _ N _ N _ N])
using psi'_l_dim mat_O_dim mat_O_mult_psi'_l hermitian_mat_O[unfolded hermitian_def] by auto
ultimately have "?m1 * ?m2 * ?m1 = tensor_P (proj_psi_l l) (proj_k l)" unfolding proj_psi_l_def by auto
}
note p1 = this
have "adjoint (tensor_P mat_O (1⇩m K)) * Q1 * (tensor_P mat_O (1⇩m K)) = ?m1 * Q1 * ?m1"
using eq by auto
also have "… = matrix_sum d (λl. ?m1 * (tensor_P (proj_psi'_l l) (proj_k l)) * ?m1) R"
unfolding Q1_def
apply (subst matrix_sum_mult_left_right) using tensor_P_dim by auto
also have "… = Q"
unfolding Q_def using p1 by auto
finally show ?thesis by auto
qed
definition Q2 where
"Q2 = matrix_sum d (λl. tensor_P (proj_psi_l (l + 1)) (proj_k l)) R"
lemma Q2_dim:
"Q2 ∈ carrier_mat d d"
unfolding Q2_def apply (subst matrix_sum_dim) using tensor_P_dim by auto
lemma Q2_le_one:
"Q2 ≤⇩L 1⇩m d"
proof -
have leq: "Q2 ≤⇩L matrix_sum d (λk. tensor_P (1⇩m N) (proj_k k)) R"
unfolding Q2_def
apply (subst lowner_le_matrix_sum)
subgoal using tensor_P_dim by auto
subgoal using tensor_P_dim by auto
using proj_psi_proj_k_le_exproj_k by auto
have "matrix_sum d (λk. tensor_P (1⇩m N) (proj_k k)) R
= tensor_P (1⇩m N) (matrix_sum K proj_k R)"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_matrix_sum2[simplified ps_P_d ps_P_d2])
subgoal using ps_P_d1 by auto
using proj_k_dim by auto
also have "… = tensor_P (1⇩m N) (proj_fst_k R)" using sum_proj_k K by auto
also have "… ≤⇩L tensor_P (1⇩m N) (1⇩m K)" unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_positive_le)
subgoal using ps_P_d1 by auto
subgoal using ps_P_d2 proj_fst_k_def by auto
subgoal using positive_one by auto
subgoal using positive_proj_fst_k by auto
subgoal using lowner_le_refl[of "1⇩m N" N] by auto
using proj_fst_k_le_one by auto
also have "… = 1⇩m d" unfolding ps2_P.ptensor_mat_def
using ps_P.tensor_mat_id ps_P_d1 ps_P_d2 ps_P_d by auto
finally have leq2: "matrix_sum d (λk. tensor_P (1⇩m N) (proj_k k)) R ≤⇩L 1⇩m d" by auto
have ds: "matrix_sum d (λk. tensor_P (1⇩m N) (proj_k k)) R ∈ carrier_mat d d"
apply (subst matrix_sum_dim) using tensor_P_dim by auto
then show ?thesis using leq leq2 lowner_le_trans[OF Q2_dim ds, of "1⇩m d"] by auto
qed
lemma qp_Q2:
"is_quantum_predicate Q2"
unfolding is_quantum_predicate_def
proof (intro conjI)
show "Q2 ∈ carrier_mat d d" unfolding Q2_def
apply (subst matrix_sum_dim) using tensor_P_dim by auto
next
show "positive Q2" unfolding Q2_def
apply (subst matrix_sum_positive)
subgoal using tensor_P_dim by auto
subgoal for k unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_positive)
subgoal using proj_psi_l_def psi_l_dim ps_P_d1 by auto
subgoal using proj_k_dim ps_P_d2 K by auto
subgoal using positive_proj_psi_l by auto
using positive_proj_k K by auto
by auto
next
show "Q2 ≤⇩L 1⇩m d" using Q2_le_one by auto
qed
lemma pre_mat:
"pre = mat N N (λ(i, j). if i = j ∧ i = 0 then 1 else 0)"
apply (rule eq_matI)
subgoal for i j unfolding pre_def apply (subst index_outer_prod[OF ket_pre_dim ket_pre_dim])
apply simp_all
unfolding ket_pre_def by auto
using outer_prod_dim[OF ket_pre_dim ket_pre_dim, folded pre_def] by auto
lemma mat_Ph_split:
"mat_Ph = 2 ⋅⇩m pre - 1⇩m N"
unfolding mat_Ph_def pre_mat
apply (rule eq_matI) by auto
lemma H_Ph_H:
"exexH_k (n-1) * tensor_P mat_Ph (1⇩m K) * exexH_k (n - 1) = 2 ⋅⇩m tensor_P proj_psi (1⇩m K) - 1⇩m d"
unfolding mat_Ph_split exexH_k.simps
apply (subst tensor_P_left_right_partial1)
subgoal using exH_k_dim[of "n - 1"] n by auto
subgoal using pre_dim by auto
subgoal by auto
proof -
have eq1: "exH_n * exH_n = 1⇩m N"
using unitary_exH_k[of "n - 1"]
unfolding unitary_def inverts_mat_def
using n hermitian_exH_n[simplified hermitian_def] exH_n_dim by auto
have eq2: "exH_n * pre * exH_n = proj_psi"
unfolding pre_def proj_psi_def
apply (subst outer_prod_left_right_mat[of _ N _ N _ N _ N])
subgoal using ket_pre_dim by auto
subgoal using exH_n_dim by auto
apply (subst hermitian_exH_n[simplified hermitian_def])
using exH_k_mult_pre_is_psi by auto
have eq3: "exH_n * (2 ⋅⇩m pre) * exH_n = 2 ⋅⇩m (exH_n * pre * exH_n)"
using pre_dim exH_n_dim by (mat_assoc N)
have "exH_n * (2 ⋅⇩m pre - 1⇩m N) * exH_n = exH_n * (2 ⋅⇩m pre) * exH_n - exH_n * exH_n"
using pre_dim exH_n_dim apply (mat_assoc N) by auto
also have "… = 2 ⋅⇩m (exH_n * pre * exH_n) - 1⇩m N"
using eq1 eq3 by auto
finally have eq4: "exH_n * (2 ⋅⇩m pre - 1⇩m N) * exH_n = 2 ⋅⇩m proj_psi - 1⇩m N" using eq2 by auto
show "tensor_P (exH_n * (2 ⋅⇩m pre - 1⇩m N) * exH_n) (1⇩m K) = 2 ⋅⇩m tensor_P proj_psi (1⇩m K) - 1⇩m d"
unfolding eq4 unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_minus1)
unfolding ps_P_d1 ps_P_d2 apply (auto simp add: proj_psi_dim)
apply (subst ps_P.tensor_mat_scale1)
unfolding ps_P_d1 ps_P_d2 apply (auto simp add: proj_psi_dim)
apply (subst ps_P.tensor_mat_id[simplified ps_P_d1 ps_P_d2 ps_P_d]) by auto
qed
lemma hermitian_proj_psi_minus_1:
"hermitian (2 ⋅⇩m proj_psi - 1⇩m N)"
unfolding hermitian_def
apply (subst adjoint_minus[of _ N N])
apply (auto simp add: proj_psi_dim)
apply (subst adjoint_scale)
using hermitian_proj_psi[simplified hermitian_def] hermitian_def adjoint_one by auto
lemma unitary_proj_psi_minus_1:
"unitary (2 ⋅⇩m proj_psi - 1⇩m N)"
proof -
have a: "adjoint (2 ⋅⇩m proj_psi) = 2 ⋅⇩m proj_psi"
apply (subst adjoint_scale) using hermitian_proj_psi[simplified hermitian_def] by simp
have eq: "adjoint (2 ⋅⇩m proj_psi - 1⇩m N) = 2 ⋅⇩m proj_psi - 1⇩m N"
apply (subst adjoint_minus) using proj_psi_dim a adjoint_one by auto
have "(2 ⋅⇩m proj_psi) * (2 ⋅⇩m proj_psi) = 4 ⋅⇩m (proj_psi * proj_psi)"
using proj_psi_dim by auto
also have "… = 4 ⋅⇩m proj_psi" using proj_psi_is_projection by auto
finally have sq: "(2 ⋅⇩m proj_psi) * (2 ⋅⇩m proj_psi) = 4 ⋅⇩m proj_psi".
have l: "(2 ⋅⇩m proj_psi) * (2 ⋅⇩m proj_psi - 1⇩m N) = 4 ⋅⇩m proj_psi - (2 ⋅⇩m proj_psi)"
apply (subst mult_minus_distrib_mat) using proj_psi_dim sq by auto
have "(2 ⋅⇩m proj_psi - 1⇩m N) * adjoint (2 ⋅⇩m proj_psi - 1⇩m N)
= (2 ⋅⇩m proj_psi - 1⇩m N) * (2 ⋅⇩m proj_psi - 1⇩m N)" using eq by auto
also have "… = (2 ⋅⇩m proj_psi) * (2 ⋅⇩m proj_psi - 1⇩m N) - 2 ⋅⇩m proj_psi + 1⇩m N"
apply (subst minus_mult_distrib_mat[of _ N N]) using proj_psi_dim by auto
also have "… = 4 ⋅⇩m proj_psi - (2 ⋅⇩m proj_psi) - 2 ⋅⇩m proj_psi + 1⇩m N"
using l by auto
also have "… = 1⇩m N" using proj_psi_dim by auto
finally have "(2 ⋅⇩m proj_psi - 1⇩m N) * adjoint (2 ⋅⇩m proj_psi - 1⇩m N) = 1⇩m N".
then show ?thesis unfolding unitary_def inverts_mat_def using proj_psi_dim by auto
qed
lemma proj_psi_minus_1_mult_psi'_l:
"(2 ⋅⇩m proj_psi - 1⇩m N) *⇩v psi'_l l = psi_l (l + 1)"
proof -
have eq1: "(2 ⋅⇩m proj_psi - 1⇩m N) *⇩v psi'_l l = 2 ⋅⇩m proj_psi *⇩v psi'_l l - psi'_l l"
apply (subst minus_mult_distrib_mat_vec)
using psi'_l_dim proj_psi'_dim proj_psi_dim by auto
have eq2: "2 ⋅⇩m proj_psi *⇩v (psi'_l l) = 2 ⋅⇩v (proj_psi *⇩v (psi'_l l))"
apply (subst smult_mat_mult_mat_vec_assoc)
using proj_psi_dim psi'_l_dim by auto
have "proj_psi *⇩v (psi'_l l) = inner_prod ψ (psi'_l l) ⋅⇩v ψ"
unfolding proj_psi_def
apply (subst outer_prod_mult_vec[of _ N _ N])
using ψ_dim psi'_l_dim by auto
also have "… = ((alpha_l l) * ccos (θ / 2) - (beta_l l) * csin (θ / 2)) ⋅⇩v ψ"
using psi_inner_psi'_l by auto
finally have "proj_psi *⇩v (psi'_l l) = ((alpha_l l) * ccos (θ / 2) - (beta_l l) * csin (θ / 2)) ⋅⇩v ψ" by auto
then have eq3: "2 ⋅⇩v (proj_psi *⇩v (psi'_l l)) = 2 * ((alpha_l l) * ccos (θ / 2) - (beta_l l) * csin (θ / 2)) ⋅⇩v ψ" by auto
then show "(2 ⋅⇩m proj_psi - (1⇩m N)) *⇩v (psi'_l l) = psi_l (l + 1)"
using eq1 eq2 eq3 psi_l_Suc_l_derive by simp
qed
lemma proj_psi_minus_1_mult_psi_Suc_l:
"(2 ⋅⇩m proj_psi - 1⇩m N) *⇩v psi_l (l + 1) = psi'_l l"
proof -
have id: "(2 ⋅⇩m proj_psi - 1⇩m N) * (2 ⋅⇩m proj_psi - 1⇩m N) = 1⇩m N"
using unitary_proj_psi_minus_1 unfolding unitary_def hermitian_proj_psi_minus_1[simplified hermitian_def]
unfolding inverts_mat_def by auto
have "(2 ⋅⇩m proj_psi - 1⇩m N) *⇩v psi_l (l + 1) = (2 ⋅⇩m proj_psi - 1⇩m N) *⇩v ((2 ⋅⇩m proj_psi - 1⇩m N) *⇩v psi'_l l)"
using proj_psi_minus_1_mult_psi'_l by auto
also have "… = ((2 ⋅⇩m proj_psi - 1⇩m N) * (2 ⋅⇩m proj_psi - 1⇩m N) *⇩v psi'_l l)"
apply (subst assoc_mult_mat_vec) using proj_psi_dim psi'_l_dim by auto
also have "… = psi'_l l" using psi'_l_dim id by auto
finally show ?thesis by auto
qed
lemma exproj_psi_minus_1_tensor:
"(2 ⋅⇩m tensor_P proj_psi (1⇩m K)) - 1⇩m d = tensor_P (2 ⋅⇩m proj_psi - (1⇩m N)) (1⇩m K)"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_id[symmetric, simplified ps_P_d])
apply (auto simp add: ps_P_d1 ps_P_d2)
apply (subst ps_P.tensor_mat_scale1[symmetric])
apply (auto simp add: ps_P_d1 ps_P_d2 proj_psi_dim)
apply (subst ps_P.tensor_mat_minus1)
by (auto simp add: ps_P_d1 ps_P_d2 proj_psi_dim)
lemma unitary_exproj_psi_minus_1:
"unitary (2 ⋅⇩m tensor_P proj_psi (1⇩m K) - 1⇩m d)"
unfolding exproj_psi_minus_1_tensor
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_unitary)
using ps_P_d1 ps_P_d2 unitary_proj_psi_minus_1 unitary_one by auto
lemma proj_psi_minus_1_Q2:
"adjoint (2 ⋅⇩m tensor_P proj_psi (1⇩m K) - 1⇩m d) * Q2 * (2 ⋅⇩m tensor_P proj_psi (1⇩m K) - 1⇩m d) = Q1"
proof -
have eq1: "adjoint (2 ⋅⇩m tensor_P proj_psi (1⇩m K) - 1⇩m d) = 2 ⋅⇩m tensor_P proj_psi (1⇩m K) - 1⇩m d"
apply (subst adjoint_minus[of _ d d])
subgoal using tensor_P_dim[of proj_psi] by auto
subgoal by auto
apply (subst adjoint_one) apply (subst adjoint_scale)
using hermitian_exproj_psi[simplified hermitian_def] by auto
let ?m1 = "tensor_P (2 ⋅⇩m proj_psi - (1⇩m N)) (1⇩m K)"
{
fix l
let ?m2 = "tensor_P (proj_psi_l (l + 1)) (proj_k l)"
have 121: "?m1 * ?m2 * ?m1
= tensor_P ((2 ⋅⇩m proj_psi - (1⇩m N)) * (proj_psi_l (l + 1)) * (2 ⋅⇩m proj_psi - (1⇩m N)))
(proj_k l)"
apply (subst tensor_P_left_right_partial1)
using proj_psi_dim proj_psi_l_dim proj_k_dim by auto
have "(2 ⋅⇩m proj_psi - (1⇩m N)) * (proj_psi_l (l + 1)) * (2 ⋅⇩m proj_psi - (1⇩m N))
= outer_prod ((2 ⋅⇩m proj_psi - (1⇩m N)) *⇩v (psi_l (l + 1))) ((2 ⋅⇩m proj_psi - (1⇩m N)) *⇩v (psi_l (l + 1)))"
unfolding proj_psi_l_def apply (subst outer_prod_left_right_mat[of _ N _ N _ N _ N])
using proj_psi_dim psi_l_dim hermitian_proj_psi_minus_1[simplified hermitian_def] by auto
also have "… = outer_prod (psi'_l l) (psi'_l l)"
using proj_psi_minus_1_mult_psi_Suc_l by auto
finally have "(2 ⋅⇩m proj_psi - (1⇩m N)) * (proj_psi_l (l + 1)) * (2 ⋅⇩m proj_psi - (1⇩m N))
= outer_prod (psi'_l l) (psi'_l l)".
then have "?m1 * ?m2 * ?m1 = tensor_P (proj_psi'_l l) (proj_k l)"
using 121 proj_psi'_l_def by auto
}
note p1 = this
have "adjoint (2 ⋅⇩m tensor_P proj_psi (1⇩m K) - 1⇩m d) * Q2 * (2 ⋅⇩m tensor_P proj_psi (1⇩m K) - 1⇩m d)
= (2 ⋅⇩m tensor_P proj_psi (1⇩m K) - 1⇩m d) * Q2 * (2 ⋅⇩m tensor_P proj_psi (1⇩m K) - 1⇩m d)"
using eq1 by auto
also have "… = matrix_sum d
(λl. (2 ⋅⇩m tensor_P proj_psi (1⇩m K) - 1⇩m d) * tensor_P (proj_psi_l (l + 1)) (proj_k l) * (2 ⋅⇩m tensor_P proj_psi (1⇩m K) - 1⇩m d))
R" unfolding Q2_def apply (subst matrix_sum_mult_left_right)
using tensor_P_dim by auto
also have "… = matrix_sum d (λl. tensor_P (proj_psi'_l l) (proj_k l)) R"
using p1 exproj_psi_minus_1_tensor by auto
also have "… = Q1" unfolding Q1_def by auto
finally show ?thesis using eq1 by auto
qed
lemma qp_Q1:
"is_quantum_predicate Q1"
unfolding proj_psi_minus_1_Q2[symmetric]
apply (subst qp_close_under_unitary_operator)
using tensor_P_dim unitary_exproj_psi_minus_1 qp_Q2 by auto
lemma qp_Q:
"is_quantum_predicate Q"
proof -
have u: "unitary (tensor_P mat_O (1⇩m K))"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_unitary)
subgoal unfolding ps_P_d1 mat_O_def by auto
subgoal unfolding ps_P_d2 by auto
subgoal using unitary_mat_O by auto
using unitary_one by auto
then show ?thesis using tensor_P_dim qp_Q1
using qp_close_under_unitary_operator[OF tensor_P_dim u qp_Q1]
by (simp add: mat_O_times_Q1 )
qed
lemma hoare_triple_D1:
"⊢⇩p
{Q}
Utrans_P vars1 mat_O
{Q1}"
unfolding Utrans_P_is_tensor_P1
mat_O_times_Q1[symmetric]
apply (subst hoare_partial.intros(2))
using qp_Q1 by auto
lemma hoare_triple_D2:
"⊢⇩p
{Q1}
hadamard_n n ;;
Utrans_P vars1 mat_Ph ;;
hadamard_n n
{Q2}"
proof -
let ?H = "exexH_k (n - 1)"
let ?Ph = "tensor_P mat_Ph (1⇩m K)"
let ?O = "tensor_P mat_O (1⇩m K)"
have h1: "⊢⇩p
{adjoint ?H * Q2 * ?H}
hadamard_n n
{Q2}"
using hoare_hadamard_n[OF qp_Q2, of "n - 1"] n by auto
have qp1: "is_quantum_predicate ((adjoint ?H) * Q2 * ?H)"
using qp_close_under_unitary_operator unitary_exexH_k n exexH_k_dim qp_Q2 by auto
then have h2: "⊢⇩p
{adjoint ?Ph * (adjoint ?H * Q2 * ?H) * ?Ph}
Utrans_P vars1 mat_Ph
{adjoint ?H * Q2 * ?H}"
using qp1 Utrans_P_is_tensor_P1 hoare_partial.intros by auto
have qp2: "is_quantum_predicate (adjoint ?Ph * (adjoint ?H * Q2 * ?H) * ?Ph)"
using qp_close_under_unitary_operator[of "tensor_P mat_Ph (1⇩m K)"] ps2_P.ptensor_mat_carrier ps2_P_d0 unitary_ex_mat_Ph qp1 by auto
then have h3: "⊢⇩p
{adjoint ?H * (adjoint ?Ph * (adjoint ?H * Q2 * ?H) * ?Ph) * ?H}
hadamard_n n
{adjoint ?Ph * (adjoint ?H * Q2 * ?H) * ?Ph}"
using hoare_hadamard_n[OF qp2, of "n - 1"] n by auto
have qp3: "is_quantum_predicate (adjoint ?H * (adjoint ?Ph * (adjoint ?H * Q2 * ?H) * ?Ph) * ?H)"
using qp_close_under_unitary_operator[of "?H"] exexH_k_dim unitary_exexH_k qp2 n by auto
have h4: "⊢⇩p
{adjoint ?H * (adjoint ?Ph * (adjoint ?H * Q2 * ?H) * ?Ph) * ?H}
hadamard_n n ;;
Utrans_P vars1 mat_Ph
{adjoint ?H * Q2 * ?H}"
using h2 h3 qp1 qp2 qp3 hoare_partial.intros by auto
then have h5: "⊢⇩p
{adjoint ?H * (adjoint ?Ph * (adjoint ?H * Q2 * ?H) * ?Ph) * ?H}
hadamard_n n ;;
Utrans_P vars1 mat_Ph ;;
hadamard_n n
{Q2}"
using h1 qp_Q2 qp3 qp1 hoare_partial.intros(3)[OF qp3 qp1 qp_Q2 h4 h1] by auto
have "adjoint ?H * (adjoint ?Ph * (adjoint ?H * Q2 * ?H) * ?Ph) * ?H =
adjoint (?H * ?Ph * ?H) * Q2 * (?H * ?Ph * ?H)"
apply (mat_assoc d) using exexH_k_dim n tensor_P_dim Q2_dim by auto
also have "… = Q1" using H_Ph_H proj_psi_minus_1_Q2 by auto
finally show ?thesis using h5 by auto
qed
definition exM0 where
"exM0 = tensor_P (1⇩m N) M0"
lemma M0_mult_ket_k_R:
"M0 *⇩v ket_k R = ket_k R"
apply (rule eq_vecI)
unfolding M0_def ket_k_def
by (auto simp add: scalar_prod_def sum_only_one_neq_0)
lemma exP0_P':
"adjoint exM0 * P' * exM0 = P'"
proof -
have eq: "adjoint exM0 = exM0"
unfolding exM0_def ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_adjoint)
unfolding ps_P_d1 ps_P_d2 using M0_dim adjoint_one hermitian_M0[unfolded hermitian_def] by auto
have eq2: "M0 * (proj_k R) * M0 = (proj_k R)"
unfolding proj_k_def
apply (subst outer_prod_left_right_mat[of _ K _ K _ K _ K])
unfolding hermitian_M0[unfolded hermitian_def] M0_mult_ket_k_R
using ket_k_dim M0_dim by auto
show ?thesis unfolding eq unfolding exM0_def P'_def
apply (subst tensor_P_left_right_partial2)
using M0_dim proj_k_dim eq2 proj_psi_l_dim by auto
qed
definition exM1 where
"exM1 = tensor_P (1⇩m N) M1"
lemma M1_mult_ket_k:
assumes "k < R"
shows "M1 *⇩v ket_k k = ket_k k"
apply (rule eq_vecI)
unfolding M1_def ket_k_def
by (auto simp add: scalar_prod_def assms R sum_only_one_neq_0)
lemma exP1_Q:
"adjoint exM1 * Q * exM1 = Q"
proof -
have eq: "adjoint exM1 = exM1"
unfolding exM1_def ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_adjoint)
unfolding ps_P_d1 ps_P_d2 using M1_dim adjoint_one hermitian_M1[unfolded hermitian_def] by auto
{
fix k assume k: "k < R"
let ?m = "tensor_P (proj_psi_l k) (proj_k k)"
have "exM1 * ?m * exM1 = tensor_P (proj_psi_l k) (M1 * (proj_k k) * M1)"
unfolding exM1_def apply (subst tensor_P_left_right_partial2)
using M1_dim proj_k_dim proj_psi_l_dim by auto
also have "… = tensor_P (proj_psi_l k) (outer_prod (M1 *⇩v ket_k k) (M1 *⇩v ket_k k))"
unfolding proj_k_def apply (subst outer_prod_left_right_mat[of _ K _ K _ K _ K])
unfolding hermitian_M1[unfolded hermitian_def]
using ket_k_dim M1_dim by auto
finally have "exM1 * ?m * exM1 = ?m" unfolding proj_k_def using k M1_mult_ket_k by auto
}
note p1 = this
have "adjoint exM1 * Q * exM1 = exM1 * Q * exM1" using eq by auto
also have "… = matrix_sum d (λk. exM1 * (tensor_P (proj_psi_l k) (proj_k k)) * exM1) R"
unfolding Q_def
apply (subst matrix_sum_mult_left_right)
using tensor_P_dim exM1_def by auto
also have "… = matrix_sum d (λk. tensor_P (proj_psi_l k) (proj_k k)) R"
apply (subst matrix_sum_cong)
using p1 by auto
finally show ?thesis using Q_def by auto
qed
lemma qp_P':
"is_quantum_predicate P'"
unfolding is_quantum_predicate_def
proof (intro conjI)
show "P' ∈ carrier_mat d d" unfolding P'_def using tensor_P_dim by auto
show "positive P'" unfolding P'_def ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_positive)
apply (auto simp add: ps_P_d1 ps_P_d2 proj_O_dim proj_k_dim)
using proj_psi_l_dim positive_proj_psi_l positive_proj_k K by auto
show "P' ≤⇩L 1⇩m d" unfolding P'_def ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_le_one[simplified ps_P_d])
by (auto simp add: ps_P_d1 ps_P_d2 proj_psi_l_dim K proj_k_dim positive_proj_psi_l positive_proj_k proj_k_le_one psi_l_le_id)
qed
lemma P'_add_Q:
"P' + Q = matrix_sum d (λl. tensor_P (proj_psi_l l) (proj_k l)) (R + 1)"
apply simp unfolding P'_def Q_def by auto
lemma positive_Qk:
"positive (tensor_P (proj_psi_l l) (proj_k l))"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_positive)
unfolding ps_P_d1 ps_P_d2
using proj_psi_l_dim proj_k_dim positive_proj_psi_l positive_proj_k by auto
lemma P'_Q_dim:
"P' + Q ∈ carrier_mat d d"
unfolding P'_add_Q
apply (subst matrix_sum_dim)
using tensor_P_dim by auto
lemma P'_add_Q_le_one:
"P' + Q ≤⇩L 1⇩m d"
proof -
have leq: "matrix_sum d (λl. tensor_P (proj_psi_l l) (proj_k l)) (R + 1)
≤⇩L matrix_sum d (λk. tensor_P (1⇩m N) (proj_k k)) (R + 1)"
unfolding Q2_def
apply (subst lowner_le_matrix_sum)
subgoal using tensor_P_dim by auto
subgoal using tensor_P_dim by auto
using proj_psi_proj_k_le_exproj_k by auto
have "matrix_sum d (λk. tensor_P (1⇩m N) (proj_k k)) (R + 1)
= tensor_P (1⇩m N) (matrix_sum K proj_k (R + 1))"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_matrix_sum2[simplified ps_P_d ps_P_d2])
subgoal using ps_P_d1 by auto
using proj_k_dim by auto
also have "… = tensor_P (1⇩m N) (proj_fst_k (R + 1))" using sum_proj_k[of "R + 1"] K by auto
also have "… ≤⇩L tensor_P (1⇩m N) (1⇩m K)" unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_positive_le)
subgoal using ps_P_d1 by auto
subgoal using ps_P_d2 proj_fst_k_def by auto
subgoal using positive_one by auto
subgoal using positive_proj_fst_k by auto
subgoal using lowner_le_refl[of "1⇩m N" N] by auto
using proj_fst_k_le_one by auto
also have "… = 1⇩m d" unfolding ps2_P.ptensor_mat_def
using ps_P.tensor_mat_id ps_P_d1 ps_P_d2 ps_P_d by auto
finally have leq2: "matrix_sum d (λk. tensor_P (1⇩m N) (proj_k k)) (R + 1) ≤⇩L 1⇩m d" by auto
have ds: "matrix_sum d (λk. tensor_P (1⇩m N) (proj_k k)) (R + 1) ∈ carrier_mat d d"
apply (subst matrix_sum_dim) using tensor_P_dim by auto
then show ?thesis
using leq leq2 lowner_le_trans[OF P'_Q_dim ds, of "1⇩m d"] unfolding P'_add_Q by auto
qed
lemma qp_P'_Q:
"is_quantum_predicate (P' + Q)"
unfolding is_quantum_predicate_def
proof (intro conjI)
show "P' + Q ∈ carrier_mat d d"
unfolding P'_add_Q apply (subst matrix_sum_dim)
using tensor_P_dim by auto
show "positive (P' + Q)" unfolding P'_add_Q
apply (subst matrix_sum_positive)
using tensor_P_dim positive_Qk by auto
show " P' + Q ≤⇩L 1⇩m d" using P'_add_Q_le_one by auto
qed
lemma Q2_leq_lemma:
"tensor_P (1⇩m N) (mat_incr K) * Q2 * adjoint (tensor_P (1⇩m N) (mat_incr K)) ≤⇩L P' + Q"
proof -
have ad: "adjoint (tensor_P (1⇩m N) (mat_incr K)) = tensor_P (1⇩m N) (adjoint (mat_incr K))"
unfolding ps2_P.ptensor_mat_def apply (subst ps_P.tensor_mat_adjoint)
using ps_P_d1 ps_P_d2 mat_incr_dim adjoint_one by auto
let ?m1 = "tensor_P (1⇩m N) (mat_incr K)"
let ?m3 = "tensor_P (1⇩m N) (adjoint (mat_incr K))"
{
fix l assume "l < R"
then have "l < K - 1" using K by auto
then have m: "(mat_incr K) *⇩v (ket_k l) = (ket_k (l + 1))"
using mat_incr_mult_ket_k by auto
let ?m2 = "tensor_P (proj_psi_l (l + 1)) (proj_k l)"
have eq: "?m1 * ?m2 * ?m3 = tensor_P (proj_psi_l (l + 1)) ((mat_incr K) * (proj_k l) * adjoint (mat_incr K))"
apply (subst tensor_P_left_right_partial2)
using proj_k_dim proj_psi_l_dim mat_incr_dim adjoint_dim[OF mat_incr_dim] by auto
have "(mat_incr K) * (proj_k l) * adjoint (mat_incr K) = outer_prod ((mat_incr K) *⇩v (ket_k l)) ((mat_incr K) *⇩v (ket_k l))"
unfolding proj_k_def apply (subst outer_prod_left_right_mat[of _ K _ K _ K _ K])
using ket_k_dim mat_incr_dim adjoint_dim[OF mat_incr_dim] adjoint_adjoint[of "mat_incr K"] by auto
also have "… = proj_k (l + 1)" unfolding proj_k_def using m by auto
finally have "?m1 * ?m2 * ?m3 = tensor_P (proj_psi_l (l + 1)) (proj_k (l + 1))" using eq by auto
}
note p1 = this
have "?m1 * Q2 * ?m3
= matrix_sum d (λl. ?m1 * (tensor_P (proj_psi_l (l + 1)) (proj_k l)) * ?m3) R"
unfolding Q2_def apply(subst matrix_sum_mult_left_right)
using tensor_P_dim by auto
also have "… = matrix_sum d (λl. tensor_P (proj_psi_l (l + 1)) (proj_k (l + 1))) R"
apply (subst matrix_sum_cong) using p1 by auto
finally have eq1: "?m1 * Q2 * ?m3 = matrix_sum d (λl. tensor_P (proj_psi_l (l + 1)) (proj_k (l + 1))) R" (is "_=?r") .
have eq2: "P' + Q = tensor_P (proj_psi_l 0) (proj_k 0) + ?r"
unfolding P'_add_Q
apply (subst matrix_sum_Suc_remove_head) using tensor_P_dim by auto
have "tensor_P (proj_psi_l 0) (proj_k 0) + ?r ≤⇩L P' + Q"
unfolding eq2[symmetric] apply (subst lowner_le_refl) using P'_Q_dim by auto
moreover have "positive (tensor_P (proj_psi_l 0) (proj_k 0))"
unfolding ps2_P.ptensor_mat_def apply (subst ps_P.tensor_mat_positive)
unfolding ps_P_d1 ps_P_d2 using proj_psi_l_dim proj_k_dim positive_proj_psi_l positive_proj_k by auto
moreover have "matrix_sum d (λl. tensor_P (proj_psi_l (l + 1)) (proj_k (l + 1))) R ∈ carrier_mat d d"
apply (subst matrix_sum_dim) using tensor_P_dim by auto
ultimately have "?r ≤⇩L P' + Q"
apply (subst add_positive_le_reduce2[of ?r d "tensor_P (proj_psi_l 0) (proj_k 0)" "P' + Q"])
using tensor_P_dim P'_Q_dim by auto
then show ?thesis using eq1 ad by auto
qed
lemma Q2_leq:
"Q2 ≤⇩L adjoint (tensor_P (1⇩m N) (mat_incr K)) * (P' + Q) * tensor_P (1⇩m N) (mat_incr K)"
proof -
let ?m1 = "tensor_P (1⇩m N) (mat_incr K)"
let ?m2 = "adjoint (tensor_P (1⇩m N) (mat_incr K))"
have "?m1 * ?m2 = 1⇩m d"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_adjoint)
unfolding ps_P_d1 ps_P_d2 apply (auto simp add: mat_incr_dim adjoint_one)
apply (subst ps_P.tensor_mat_mult[symmetric])
unfolding ps_P_d1 ps_P_d2 apply (auto simp add: mat_incr_dim adjoint_dim mat_incr_mult_adjoint_mat_incr)
using ps_P.tensor_mat_id ps_P_d ps_P_d1 ps_P_d2 by auto
then have inv: "?m2 * ?m1 = 1⇩m d"
using mat_mult_left_right_inverse[of ?m1 d ?m2]
tensor_P_dim adjoint_dim by auto
have d: "?m1 * Q2 * ?m2 ∈ carrier_mat d d" using tensor_P_dim adjoint_dim[OF tensor_P_dim] Q2_dim by fastforce
have le: "?m2 * (?m1 * Q2 * ?m2) * ?m1 ≤⇩L ?m2 * (P' + Q) * ?m1" (is "lowner_le ?l ?r")
apply (subst lowner_le_keep_under_measurement[of _ d])
using Q2_leq_lemma tensor_P_dim P'_Q_dim d by auto
have "?l = (?m2 * ?m1) * Q2 * (?m2 * ?m1)"
apply (mat_assoc d) using tensor_P_dim Q2_dim by auto
also have "… = 1⇩m d * Q2 * 1⇩m d" using inv by auto
also have "… = Q2" using Q2_dim by auto
finally have eq: "?l = Q2".
show ?thesis using eq le by auto
qed
lemma hoare_triple_D3:
"⊢⇩p
{Q2}
Utrans_P vars2 (mat_incr K)
{adjoint exM0 * P' * exM0 + adjoint exM1 * Q * exM1}"
unfolding exP0_P' exP1_Q
proof -
let ?m = "tensor_P (1⇩m N) (mat_incr K)"
have h1: "⊢⇩p
{adjoint ?m * (P' + Q) * ?m}
Utrans ?m
{P' + Q}"
using qp_P'_Q hoare_partial.intros by auto
have qp: "is_quantum_predicate (adjoint ?m * (P' + Q) * ?m)"
using qp_close_under_unitary_operator tensor_P_dim qp_P'_Q unitary_exmat_incr by auto
then have "⊢⇩p
{Q2}
Utrans ?m
{P' + Q}"
using hoare_partial.intros(6)[OF qp_Q2 qp_P'_Q qp qp_P'_Q] Q2_leq h1 lowner_le_refl[OF P'_Q_dim] by auto
moreover have "Utrans ?m = Utrans_P vars2 (mat_incr K)"
apply (subst Utrans_P_is_tensor_P2) unfolding mat_incr_def by auto
ultimately show "⊢⇩p {Q2} Utrans_P vars2 (mat_incr K) {P' + Q}" by auto
qed
lemma qp_D3_post:
"is_quantum_predicate (adjoint exM0 * P' * exM0 + adjoint exM1 * Q * exM1)"
unfolding exP0_P' exP1_Q using qp_P'_Q by auto
lemma hoare_triple_D:
"⊢⇩p
{Q}
D
{adjoint exM0 * P' * exM0 + adjoint exM1 * Q * exM1}"
proof -
have "⊢⇩p {Q1} hadamard_n n;; (Utrans_P vars1 mat_Ph;; hadamard_n n) {Q2}"
using well_com_hadamard_n well_com_mat_Ph hoare_triple_D2 qp_Q1 qp_Q2 by (auto simp add: hoare_patial_seq_assoc)
then have "⊢⇩p {Q} Utrans_P vars1 mat_O;; (hadamard_n n;; (Utrans_P vars1 mat_Ph;; hadamard_n n)) {Q2}"
using hoare_triple_D1 qp_Q qp_Q1 qp_Q2 hoare_partial.intros(3) by auto
moreover have "well_com (Utrans_P vars1 mat_Ph;; hadamard_n n)" using well_com_hadamard_n well_com_mat_Ph by auto
ultimately have "⊢⇩p {Q} (Utrans_P vars1 mat_O;; hadamard_n n);; (Utrans_P vars1 mat_Ph;; hadamard_n n) {Q2}"
using well_com_hadamard_n well_com_mat_O qp_Q qp_Q2 by (auto simp add: hoare_patial_seq_assoc)
moreover have "well_com (Utrans_P vars1 mat_O;; hadamard_n n)"
using well_com_mat_O well_com_hadamard_n by auto
ultimately have "⊢⇩p {Q} Utrans_P vars1 mat_O;; hadamard_n n;; Utrans_P vars1 mat_Ph;; hadamard_n n {Q2}"
using well_com_hadamard_n well_com_mat_Ph qp_Q qp_Q2 by (auto simp add: hoare_patial_seq_assoc)
with qp_Q qp_Q2 qp_D3_post hoare_triple_D3 show "⊢⇩p
{Q}
D
{adjoint exM0 * P' * exM0 + adjoint exM1 * Q * exM1}"
unfolding D_def using hoare_partial.intros(3) by auto
qed
lemma psi_is_psi_l0:
"ψ = psi_l 0"
unfolding ψ_eq psi_l_def alpha_l_def beta_l_def by auto
lemma proj_psi_is_proj_psi_l0:
"proj_psi = proj_psi_l 0"
unfolding proj_psi_def psi_is_psi_l0 proj_psi_l_def by auto
lemma lowner_le_Q:
"tensor_P proj_psi (proj_k 0) ≤⇩L adjoint exM0 * P' * exM0 + adjoint exM1 * Q * exM1"
proof -
let ?r = "matrix_sum d (λl. tensor_P (proj_psi_l l) (proj_k l)) (R + 1)"
let ?l = "tensor_P (proj_psi_l 0) (proj_k 0)"
have eq: "?r = ?l + matrix_sum d (λl. tensor_P (proj_psi_l (l + 1)) (proj_k (l + 1))) R" (is "_ = _ + ?s")
apply (subst matrix_sum_Suc_remove_head)
using tensor_P_dim by auto
have d: "?s ∈ carrier_mat d d"
apply (subst matrix_sum_dim) using tensor_P_dim by auto
have pt: "positive (tensor_P (proj_psi_l l) (proj_k l))" for l
unfolding ps2_P.ptensor_mat_def apply (subst ps_P.tensor_mat_positive)
unfolding ps_P_d1 ps_P_d2 using proj_psi_l_dim proj_k_dim positive_proj_psi_l positive_proj_k by auto
have ps: "positive ?s"
apply (subst matrix_sum_positive)
subgoal using tensor_P_dim by auto
using pt by auto
have "?l ≤⇩L ?r"
unfolding eq
apply (subst add_positive_le_reduce1[of ?l d ?s])
subgoal using tensor_P_dim by auto
subgoal using d by auto
subgoal using tensor_P_dim d by auto
subgoal using ps by auto
apply (subst lowner_le_refl[of _ d])
using tensor_P_dim d by auto
then show ?thesis unfolding exP0_P' exP1_Q P'_add_Q proj_psi_is_proj_psi_l0 by auto
qed
lemma hoare_triple_while:
"⊢⇩p
{adjoint exM0 * P' * exM0 + adjoint exM1 * Q * exM1}
While_P vars2 M0 M1 D
{P'}"
proof -
let ?m = "λ(n::nat). if n = 0 then mat_extension dims vars2 M0 else
if n = 1 then mat_extension dims vars2 M1 else undefined"
have dM0: "M0 ∈ carrier_mat K K" unfolding M0_def by auto
have dM1: "M1 ∈ carrier_mat K K" unfolding M1_def by auto
have m0: "?m 0 = exM0" apply (simp) unfolding exM0_def ps2_P.ptensor_mat_def mat_ext_vars2[OF dM0] by auto
have m1: "?m 1 = exM1" unfolding exM1_def ps2_P.ptensor_mat_def mat_ext_vars2[OF dM1] by auto
have "⊢⇩p {Q} D {adjoint (?m 0) * P' * (?m 0) + adjoint (?m 1) * Q * (?m 1)}"
using hoare_triple_D m0 m1 by auto
then show ?thesis unfolding While_P_def using qp_D3_post qp_P' hoare_partial.intros(5)[OF qp_P' qp_Q, of D ?m] m0 m1 by auto
qed
lemma R_and_a_half_θ:
"(R + 1/2) * θ = pi / 2"
using R θ_neq_0 by auto
lemma psi_lR_is_beta:
"psi_l R = β"
unfolding psi_l_def alpha_l_def beta_l_def R_and_a_half_θ by auto
lemma post_mult_beta:
"post *⇩v β = β"
by (auto simp add: post_def β_def scalar_prod_def sum_only_one_neq_0)
lemma post_mult_post:
"post * post = post"
by (auto simp add: post_def scalar_prod_def sum_only_one_neq_0)
lemma post_mult_proj_psi_lR:
"post * proj_psi_l R = proj_psi_l R"
proof -
let ?R = "proj_psi_l R"
have "post * ?R = post * ?R * 1⇩m N"
using post_dim proj_psi_l_dim[of R] by auto
also have "… = outer_prod (post *⇩v psi_l R) ((1⇩m N) *⇩v psi_l R)"
unfolding proj_psi_l_def
apply (subst outer_prod_left_right_mat[of _ N _ N _ N _ N])
by (auto simp add: psi_l_dim post_dim adjoint_one)
also have "… = ?R" unfolding proj_psi_l_def unfolding psi_lR_is_beta unfolding post_mult_beta
using β_dim by auto
finally show "post * ?R = ?R".
qed
lemma proj_psi_lR_mult_post:
"proj_psi_l R * post = proj_psi_l R"
proof -
let ?R = "proj_psi_l R"
have "?R * post = 1⇩m N * ?R * post"
using post_dim proj_psi_l_dim[of R] by auto
also have "… = outer_prod ((1⇩m N) *⇩v psi_l R) (post *⇩v psi_l R)"
unfolding proj_psi_l_def
apply (subst outer_prod_left_right_mat[of _ N _ N _ N _ N])
by (auto simp add: psi_l_dim post_dim hermitian_post[unfolded hermitian_def])
also have "… = ?R" unfolding proj_psi_l_def unfolding psi_lR_is_beta unfolding post_mult_beta
using β_dim by auto
finally show "?R * post = ?R".
qed
lemma proj_psi_lR_mult_proj_psi_lR:
"proj_psi_l R * proj_psi_l R = proj_psi_l R"
unfolding proj_psi_l_def psi_lR_is_beta
apply (subst outer_prod_mult_outer_prod[of _ N _ N _ _ N])
by (auto simp add: β_inner)
lemma proj_psi_lR_le_post:
"proj_psi_l R ≤⇩L post"
proof -
let ?R = "proj_psi_l R"
let ?s = "post - ?R"
have eq1: "post * (post - ?R) = post - ?R"
apply (subst mult_minus_distrib_mat[of _ N N _ N])
apply (auto simp add: post_dim proj_psi_l_dim[of R])
using post_mult_post post_mult_proj_psi_lR by auto
have eq2: "?R * (post - ?R) = 0⇩m N N"
apply (subst mult_minus_distrib_mat[of _ N N _ N])
apply (auto simp add: post_dim proj_psi_l_dim[of R])
unfolding proj_psi_lR_mult_post proj_psi_lR_mult_proj_psi_lR
using proj_psi_l_dim[of R] by auto
have "adjoint ?s = ?s"
apply (subst adjoint_minus[of _ N N])
using post_dim proj_psi_l_dim hermitian_post hermitian_proj_psi_l K by (auto simp add: hermitian_def)
then have "?s * adjoint ?s = ?s * ?s" by auto
also have "… = post * (post - ?R) - ?R * (post - ?R)"
using post_dim proj_psi_l_dim[of R] by (mat_assoc N)
also have "… = post - ?R"
unfolding eq1 eq2 using post_dim proj_psi_l_dim[of R] by auto
finally have "?s * adjoint ?s = ?s".
then have "∃M. M * adjoint M = ?s" by auto
then have "positive ?s" apply (subst positive_if_decomp[of ?s N]) using post_dim proj_psi_l_dim[of R] by auto
then show ?thesis unfolding lowner_le_def using post_dim proj_psi_l_dim[of R] by auto
qed
lemma P'_le_post_R:
"P' ≤⇩L (tensor_P post (proj_k R))"
proof -
let ?r = "tensor_P post (proj_k R)"
have "?r - P' = tensor_P (post - proj_psi_l R) (proj_k R)"
unfolding P'_def ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_minus1)
unfolding ps_P_d1 ps_P_d2
using post_dim proj_psi_l_dim proj_k_dim by auto
moreover have "positive (tensor_P (post - proj_psi_l R) (proj_k R))"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_positive)
unfolding ps_P_d1 ps_P_d2
using proj_psi_lR_le_post[unfolded lowner_le_def]
post_dim proj_psi_l_dim[of R] proj_k_dim positive_proj_k
by auto
ultimately show "P' ≤⇩L ?r"
unfolding lowner_le_def P'_def
using tensor_P_dim by auto
qed
lemma positive_post:
"positive post"
proof -
have ad: "adjoint post = post" using hermitian_post[unfolded hermitian_def] by auto
then have "post * adjoint post = post"
unfolding ad post_mult_post by auto
then have "∃M. M * adjoint M = post" by auto
then show ?thesis using positive_if_decomp post_dim by auto
qed
lemma lowner_le_P':
"P' ≤⇩L tensor_P post (1⇩m K)"
proof -
let ?r = "tensor_P post (1⇩m K)"
let ?m = "tensor_P post (proj_k R)"
have "?m ≤⇩L ?r"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_positive_le)
unfolding ps_P_d1 ps_P_d2
using post_dim proj_k_dim positive_post positive_proj_k
lowner_le_refl[of post] proj_k_le_one by auto
then show "P' ≤⇩L ?r"
using lowner_le_trans[of P' d ?m ?r] P'_le_post_R
unfolding P'_def using tensor_P_dim by auto
qed
lemma post_mult_testNk:
assumes "f k"
shows "post * (testN k) = testN k"
using assms by (auto simp add: post_def testN_def scalar_prod_def sum_only_one_neq_0)
lemma post_mult_testNk_neg:
assumes "¬ f k"
shows "post * testN k = 0⇩m N N"
using assms by (auto simp add: post_def testN_def scalar_prod_def sum_only_one_neq_0)
lemma testN_post1:
"f k ⟹ adjoint (testN k) * post * testN k = testN k"
apply (subst assoc_mult_mat[of _ N N _ N _ N])
apply (auto simp add: adjoint_dim testN_dim post_dim)
apply (subst post_mult_testNk, simp)
unfolding hermitian_testN[unfolded hermitian_def]
using testN_mult_testN by auto
lemma testN_post2:
"¬ f k ⟹ adjoint (testN k) * post * testN k = 0⇩m N N"
apply (subst assoc_mult_mat[of _ N N _ N _ N])
apply (auto simp add: adjoint_dim testN_dim post_dim)
apply (subst post_mult_testNk_neg, simp)
unfolding hermitian_testN[unfolded hermitian_def]
using testN_dim[of k] by auto
definition post_fst_k :: "nat ⇒ complex mat" where
"post_fst_k k = mat N N (λ(i, j). if (i = j ∧ f i ∧ i < k) then 1 else 0)"
lemma post_fst_kN:
"post_fst_k N = post"
unfolding post_fst_k_def post_def by auto
lemma post_fst_k_Suc:
"f i ⟹ post_fst_k (Suc i) = testN i + post_fst_k i"
apply (rule eq_matI)
unfolding post_fst_k_def testN_def by auto
lemma post_fst_k_Suc_neg:
"¬ f i ⟹ post_fst_k (Suc i) = post_fst_k i"
apply (rule eq_matI)
unfolding post_fst_k_def
apply auto
using less_antisym by fastforce
lemma testN_sum:
"matrix_sum N (λk. adjoint (testN k) * post * testN k) N = post"
proof -
have "m ≤ N ⟹ matrix_sum N (λk. adjoint (testN k) * post * testN k) m = post_fst_k m" for m
proof (induct m)
case 0
then show ?case apply simp unfolding post_fst_k_def by auto
next
case (Suc m)
then have m: "m ≤ N" by auto
show ?case
proof (cases "f m")
case True
show ?thesis apply simp
apply (subst testN_post1[OF True])
apply (subst Suc(1)[OF m])
using post_fst_k_Suc True by auto
next
case False
show ?thesis apply simp
apply (subst testN_post2[OF False])
apply (subst Suc(1)[OF m])
using post_fst_k_Suc_neg False post_fst_k_def by auto
qed
qed
then show ?thesis using post_fst_kN by auto
qed
lemma tensor_P_testN_sum:
"matrix_sum d (λk. adjoint (tensor_P (testN k) (1⇩m K)) * tensor_P post (1⇩m K) * tensor_P (testN k) (1⇩m K)) N =
tensor_P post (1⇩m K)"
proof -
have eq: "adjoint (tensor_P (testN k) (1⇩m K)) * tensor_P post (1⇩m K) * tensor_P (testN k) (1⇩m K) =
tensor_P (adjoint (testN k) * post * (testN k)) (1⇩m K)" for k
apply (subst tensor_P_adjoint_left_right)
subgoal unfolding testN_def by auto
subgoal by auto
subgoal using post_dim by auto
using adjoint_one by auto
moreover have "matrix_sum N (λk. adjoint (testN k) * post * testN k) N = post"
using testN_sum by auto
show ?thesis unfolding eq
apply (subst matrix_sum_tensor_P1)
subgoal unfolding testN_def by auto
subgoal by auto
using testN_sum by auto
qed
lemma post_le_one:
"post ≤⇩L 1⇩m N"
proof -
let ?s = "1⇩m N - post"
have eq1: "1⇩m N * (1⇩m N - post) = 1⇩m N - post"
apply (mat_assoc N) using post_dim by auto
have eq2: "post * (1⇩m N - post) = 0⇩m N N"
apply (subst mult_minus_distrib_mat[of _ N N])
using post_dim by (auto simp add: post_mult_post)
have "adjoint ?s = ?s"
apply (subst adjoint_minus)
apply (auto simp add: post_dim adjoint_dim)
using adjoint_one hermitian_post[unfolded hermitian_def] by auto
then have "?s * adjoint ?s = ?s * ?s" by auto
also have "… = 1⇩m N * (1⇩m N - post) - post * (1⇩m N - post)"
apply (mat_assoc N) using post_dim by auto
also have "… = ?s" unfolding eq1 eq2 using post_dim by auto
finally have "?s * adjoint ?s = ?s".
then have "∃M. M * adjoint M = ?s" by auto
then have "positive ?s" apply (subst positive_if_decomp[of ?s N]) using post_dim by auto
then show ?thesis unfolding lowner_le_def using post_dim by auto
qed
lemma qp_post:
"is_quantum_predicate (tensor_P post (1⇩m K))"
unfolding is_quantum_predicate_def
proof (intro conjI)
show "tensor_P post (1⇩m K) ∈ carrier_mat d d"
using tensor_P_dim by auto
show "positive (tensor_P post (1⇩m K))"
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_positive)
by (auto simp add: ps_P_d1 ps_P_d2 post_dim positive_post positive_one)
show "tensor_P post (1⇩m K) ≤⇩L 1⇩m d"
unfolding ps_P.tensor_mat_id[symmetric, unfolded ps_P_d ps_P_d1 ps_P_d2]
unfolding ps2_P.ptensor_mat_def
apply (subst ps_P.tensor_mat_positive_le)
unfolding ps_P_d1 ps_P_d2 using post_dim positive_post positive_one post_le_one lowner_le_refl[of "1⇩m K" K]
by auto
qed
lemma hoare_triple_if:
"⊢⇩p
{tensor_P post (1⇩m K)}
Measure_P vars1 N testN (replicate N SKIP)
{tensor_P post (1⇩m K)}"
proof -
define M where "M = (λn. mat_extension dims vars1 (testN n))"
define Post where "Post = (λ(k::nat). tensor_P post (1⇩m K))"
have M: "M = (λn. tensor_P (testN n) (1⇩m K))"
unfolding M_def using mat_ext_vars1 by auto
have skip: "⋀k. k < N ⟹ (replicate N SKIP) ! k = SKIP" by simp
have h: "⋀k. k < N ⟹ ⊢⇩p {Post k} replicate N SKIP ! k {tensor_P post (1⇩m K)}"
unfolding Post_def skip using qp_post hoare_partial.intros by auto
moreover have "⋀k. k < N ⟹ is_quantum_predicate (Post k)" unfolding Post_def using qp_post by auto
ultimately show ?thesis
unfolding Measure_P_def apply (fold M_def)
using hoare_partial.intros(4)[of N Post "tensor_P post (1⇩m K)" "replicate N SKIP" M]
unfolding M Post_def using tensor_P_testN_sum qp_post by auto
qed
theorem grover_partial_deduct:
"⊢⇩p
{tensor_P pre (proj_k 0)}
Grover
{tensor_P post (1⇩m K)}"
unfolding Grover_def
proof -
have "⊢⇩p
{tensor_P pre (proj_k 0)}
hadamard_n n
{adjoint exM0 * P' * exM0 + adjoint exM1 * Q * exM1}"
using hoare_partial.intros(6)[OF qp_pre qp_D3_post qp_pre qp_init_post]
hoare_triple_init lowner_le_refl[OF tensor_P_dim] lowner_le_Q by auto
then have "⊢⇩p
{tensor_P pre (proj_k 0)}
hadamard_n n;;
While_P vars2 M0 M1 D
{P'}"
using hoare_triple_while hoare_partial.intros(3) qp_pre qp_D3_post qp_P' by auto
then have "⊢⇩p
{tensor_P pre (proj_k 0)}
hadamard_n n;;
While_P vars2 M0 M1 D
{tensor_P post (1⇩m K)}"
using lowner_le_P' hoare_partial.intros(6)[OF qp_pre qp_post qp_pre qp_P']
lowner_le_P' lowner_le_refl[OF tensor_P_dim] by auto
then show " ⊢⇩p
{tensor_P pre (proj_k 0)}
hadamard_n n;;
While_P vars2 M0 M1 D;;
Measure_P vars1 N testN (replicate N SKIP)
{tensor_P post (1⇩m K)}"
using hoare_triple_if qp_pre qp_post hoare_partial.intros(3) by auto
qed
theorem grover_partial_correct:
"⊨⇩p
{tensor_P pre (proj_k 0)}
Grover
{tensor_P post (1⇩m K)}"
using grover_partial_deduct well_com_Grover qp_pre qp_post hoare_partial_sound by auto
end
end